分析DFM文件生成程序界面

近回答了一個問題，是關於根據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.