分析DFM文件生成程序界面

【 tulaoshi.com - 编程语言 】

　　近回答了一个问题，是关于根据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.Count0 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.Count0 then  TComponent(L.Items[0]).free;
　　   FreeAndNil(L);
　　   FreeAndNil(TS);
　　end;
　　//生成组件
　　procedure TForm1.GetControl(P: TWinControl);
　　var Con:TComponent;
　　begin
　　  while CurpSS.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 (CurpSS.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 (CurpSS.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 (iTS.Count-1)do
　　 begin
　　   temps:=TS[i];
　　   if temps[length(temps)]= bChar then
　　     break;
　　   inc(i);
　　 end;
　　 while(temps[length(temps)]eChar)and (iTS.Count-1)do
　　   TS.Delete(i);
　　 if (iTS.Count-1) then
　　   TS.Delete(i);
　　end;

　　end.