分析DFM文件生成程序界面

2019-11-18 18:14:13

字體：大中小

來源：轉載

供稿：網友

近回答了一個問題，是關于根據DFM文件來生成程序的界面的，花了數天的研究，對于一般的程序界面
基本可以還原了。不敢自留，在這里將代碼貼出來，里面沒有多少解釋，可能閱讀不大方便，在這里表示
抱歉，本人沒有多少時間，所以就請各位有興趣地自己分析代碼了。
其主要思路是用遞歸的方式來分析DFM文件，再用流化技術將類生成出來。以下是代碼：

/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
下面這個單元是注冊組件類的，還可以增加，有興趣者可以自己加上去。
unit UClass;

interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Contnrs,
ActiveX,
ActnList,
ADODB,
Buttons,
Clipbrd,
CommCtrl,
ComObj,
ComServ,
DateUtils,
DBCtrls,
DBGrids,
DBTables,
ExtCtrls,
Grids,
IniFiles,
Isapi,
Isapi2,
Mask,
Math,
Menus,
Midas,
MMSystem,
MPlayer,
msxml,
OleDB,
OpenGL,
PRinters,
Registry,
RichEdit,
ScktComp,
ShellAPI,
ShlObj,
SvcMgr,
SyncObjs,
UrlMon,
WinInet,
WinSock,
WinSpool;

procedure RegClass;
var
ClassArr: Array[0..57] of TPersistentClass;

implementation

procedure RegClass;
begin
ClassArr[0] := TAnimate;
ClassArr[1] := TButton;
ClassArr[2] := TCheckBox;
ClassArr[3] := TColorDialog;
ClassArr[4] := TComboBox;
ClassArr[5] := TComboBoxEx;
ClassArr[6] := TCommonCalendar;
ClassArr[7] := TCommonDialog;
ClassArr[8] := TCoolBand;
ClassArr[9] := TCoolBands;
ClassArr[10] := TCoolBar;
ClassArr[11] := TDateTimePicker;
ClassArr[12] := TEdit;
ClassArr[13] := TFindDialog;
ClassArr[14] := TFontDialog;
ClassArr[15] := TForm;
ClassArr[16] := TFrame;
ClassArr[17] := TGroupBox;
ClassArr[18] := THeaderControl;
ClassArr[19] := TImageList;
ClassArr[20] := TLabel;
ClassArr[21] := TListBox;
ClassArr[22] := TListItem;
ClassArr[23] := TListView;
ClassArr[24] := TMemo;
ClassArr[25] := TMonthCalendar;
ClassArr[26] := TOpenDialog;
ClassArr[27] := TPageControl;
ClassArr[28] := TPageScroller;
ClassArr[29] := TPrintDialog;
ClassArr[30] := TProgressBar;
ClassArr[31] := TRadioButton;
ClassArr[32] := TReplaceDialog;
ClassArr[33] := TRichEdit;
ClassArr[34] := TSaveDialog;
ClassArr[35] := TScrollBar;
ClassArr[36] := TScrollBox;
ClassArr[37] := TStaticText;
ClassArr[38] := TStatusBar;
ClassArr[39] := TStatusPanel;
ClassArr[40] := TTabControl;
ClassArr[41] := TTabSheet;
ClassArr[42] := TToolBar;
ClassArr[43] := TToolButton;
ClassArr[44] := TTrackBar;
ClassArr[45] := TTreeNode;
ClassArr[46] := TTreeView;
ClassArr[47] := TUpDown;
ClassArr[48] := TPanel;
ClassArr[49] := TBitBtn;
CLassArr[50] := TShape;
ClassArr[51] :=TRadioGroup;
ClassArr[52] :=TImage;
ClassArr[53] :=TMediaPlayer;
ClassArr[54] :=TPaintBox;
ClassArr[55] :=TSpeedButton;
ClassArr[56] :=TMainMenu;
ClassArr[57] := TMenuItem;
RegisterClasses(ClassArr);
end;

initialization
RegClass;
finalization
UnRegisterClasses(ClassArr);

end.

//////////////////////////////////////////////////////////////////////////////////////////////////////////////////
下面這個就是程序的單元了，不多說了。
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ComCtrls, Contnrs,UClass;

type
TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Panel1: TPanel;
    Panel2: TPanel;
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
private
    { Private declarations }
    CurP:integer; //DFM文件的當前行
    SS:TStrings;   //保存DFM文件的文本格式
    TS:TStrings;   //保存DFM文件中的一個類的文本格式
    L:TList;       //管理DFM文件的所有類
public
    { Public declarations }
    procedure GetControl(P:TWinControl); //根據分析DFM文件來生成組件類，其中有遞歸
    procedure CorrectTS(TS:TStrings);     //將組件的一些屬性去掉，這些屬性無法由流化技術來生成
    function StrtoCom(TS:TStrings):TComponent; //根據組件類文本生成組件
    function CheckEvent:boolean;   //檢查是否事件屬性
    function isControl(com:TComponent):boolean;   //檢查是否從TCotrol繼承下來的
    procedure TestShow(TS:TStrings);//在Memo1中顯示所有的類文本
    procedure delProp(TS:TStrings; bChar,eChar:char); //消掉一些特定的屬性，為CorrectTS調用
published
end;

var
Form1: TForm1;

implementation
uses TypInfo;

{$R *.dfm}
//字符串轉化為組件
function TForm1.StrToCom(TS: Tstrings): TComponent;
var
StrStream: TStringStream;
MemStream: TMemoryStream;
begin
StrStream := TStringStream.Create(TS.Text);
try
    MemStream := TMemoryStream.Create();
    try
      Classes.ObjectTextToBinary(StrStream, MemStream);
      MemStream.Seek(0, soFromBeginning);
      Result := MemStream.ReadComponent(nil);
    finally
      FreeAndNil(MemStream);
    end;
finally
    FreeAndNil(StrStream);
end;
end;
//打開DFM文件，并顯示在Memo1中，DFM文件有可能是二進制格式，
//也有可能是文本格式，所以這里要進行判斷，并最終以文本格式打開
procedure TForm1.Button1Click(Sender: TObject);
var m:TmemoryStream; S:TStringStream;
    F:array[1..6] of Char; temps:string;
begin
if OpenDialog1.Execute then
begin
    S := TStringStream.Create('');
    M := TMemoryStream.Create();
    try
      M.LoadFromFile(Opendialog1.FileName);
      M.Position:=0;
      M.Read(F,6);
      temps:=F;
      if temps='object' then//如果是文本格式
      begin
        M.Position:=0;
        S.Position:=0;
        S.CopyFrom(M,0);
      end
      else begin//如果是二進制格式
        M.Position:=16;
        Classes.ObjectBinaryToText(M,S);
      end;
       S.Position:=0;
       SS.Text:=S.DataString;
       Memo1.Lines:=ss;
    finally
      S.Free;
      M.Free;
    end;
end;
end;

//分析DFM文件，并生成組件類
procedure TForm1.Button2Click(Sender: TObject);
begin
if L.Count>0 then TComponent(L.Items[0]).free;
L.Clear;
Curp:=0;
GetControl(nil);//這里用到了遞歸
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   SS:=TStringList.Create;
   TS:=TStringList.Create;
   L:=TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   FreeAndNil(SS);
   if L.Count>0 then TComponent(L.Items[0]).free;
   FreeAndNil(L);
   FreeAndNil(TS);
end;
//生成組件
procedure TForm1.GetControl(P: TWinControl);
var Con:TComponent;
begin
while Curp<SS.Count-1 do
begin
    if (pos('end',SS[curp])>0) then
     begin inc(curp); break; end;
    TS.Clear;
    TS.Add(SS[Curp]);
    inc(Curp);
    while (Curp<SS.Count-1) do
    begin
      if (Pos('end',SS[curp])>0) or(pos('object',SS[curp])>0) then break;
      if not CheckEvent then
        TS.Add(SS[curp]);
      inc(curp);
    end;
    TS.Add('end');
    CorrectTS(TS);
    Con:=StrtoCom(TS);
    TestShow(TS);
    if isControl(Con) then
      TControl(Con).Parent:=P;
    L.Add(Con);
    if con.ClassName='TForm' then TForm(con).Show;
    if (Pos('object',SS[curp])>0) then
      GetControl(TWincontrol(Con)); //遞歸
    if (Curp<SS.Count-1) then
     if (pos('end',SS[curp])>0) then inc(curp);
end;
end;

procedure TForm1.CorrectTS(TS: TStrings);
var cout,i:integer; temps:string;
begin
cout:=Pos('object',TS[0]);//如果是TForm的子類，將其換成TForm類
if cout=1 then
begin
   i:=pos(':',TS[0]);
   temps:=Copy(TS[0],1,i);
   temps:=temps+' Tform';
   TS[0]:=temps;
   exit;
end;
delProp(TS,'(',')');//消掉TStrings屬性
delProp(TS,'<','>');//消掉Items屬性
end;

function TForm1.CheckEvent: boolean;
var tstr:string;
begin
result:=false;
tstr:=trim(SS[curp]);
if (tstr[1]='O') and (tstr[2]='n') then
result:=true;
end;

function TForm1.isControl(com:TComponent): boolean;
begin
result:=false;
if Com.InheritsFrom(TControl) then
result:=true;
end;

procedure TForm1.TestShow(TS: TStrings);
var i:integer;
begin
for i:=0 to TS.Count-1 do
Memo1.Lines.Add(TS.Strings[i]);
end;

procedure TForm1.delProp(TS: TStrings; bChar, eChar: char);
var i:integer; temps:string;
begin
i:=0;
while (i<TS.Count-1)do
begin
   temps:=TS[i];
   if temps[length(temps)]= bChar then
     break;
   inc(i);
end;
while(temps[length(temps)]<>eChar)and (i<TS.Count-1)do
   TS.Delete(i);
if (i<TS.Count-1) then
   TS.Delete(i);
end;

end.

上一篇：SaveComponentByFile

下一篇：在MSSQL版參與問題有所感觸