可以用动态桌面技术{*****************************************模块编号：J001DfmFunc模块名称：Dfm窗体函数集单元作者：刘爱军建立日期：2002年12月2日最后修改日期： 2010-11-14修改人：祁书锋说明：本Unit包含了一些函数，用于根据Delphi窗体文件格式的文件动态创建窗体*******************************************}unit J001DfmFunc;interfaceusesWindows, Messages, SysUtils, Variants, //自定义控件 //DBNavPlus,// Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, Buttons, Menus, Mask, Grids, CheckLst, MPlayer, ExtDlgs, Gauges, ColorGrd, Spin, ActnList, OleCtnrs, AppEvnts, ValEdit, ActnMan, ActnMenus, ActnCtrls, ActnColorMaps, CustomizeDlg, dblookup, Tabs, Outline, TabNotBk, FileCtrl, DirOutln, Calendar, DBGrids, DBCtrls, dbcgrids ;typeTUnknown = class(TCustomControl) ;function ComponentToString(Component: TComponent): string;function StringToComponent(Value: string; Instance:TComponent): TComponent;function GetObjectString(list:TStrings;BegLine:Integer=0;TypeString:string=''):string;function LoadTextForm(FileName:String):TForm;function LoadTextForm2(FileName:String;out ErrMsg:string):TForm;procedure DeleteErrorLines(list:TStrings);procedure ReadForm(aFrom : TComponent;aFileName :string='');implementationfunction ComponentToString(Component: TComponent): string;var BinStream:TMemoryStream; StrStream: TStringStream; s: string;begin BinStream := TMemoryStream.Create; try StrStream := TStringStream.Create(s); try BinStream.WriteComponent(Component); BinStream.Seek(0, soFromBeginning); ObjectBinaryToText(BinStream, StrStream); StrStream.Seek(0, soFromBeginning); Result:= StrStream.DataString; finally StrStream.Free; end; finally BinStream.Free end;end;function StringToComponent(Value: string; Instance:TComponent): TComponent;var StrStream:TStringStream; BinStream: TMemoryStream;begin StrStream := TStringStream.Create(Value); try BinStream := TMemoryStream.Create; try ObjectTextToBinary(StrStream, BinStream); BinStream.Seek(0, soFromBeginning); Result := BinStream.ReadComponent(Instance); finally BinStream.Free; end; finally StrStream.Free; end;end;function GetObjectString(list:TStrings;BegLine:Integer=0;TypeString:string=''):string;var i,iBegCount,iEndCount:Integer; ObjString,Line,ClassStr:String;begin iBegCount:=0; iEndCount:=0; ClassStr := Trim(UpperCase(TypeString)); for i:=BegLine to list.Count-1 do begin line := UpperCase(list); if Pos('OBJECT',line)>0 then begin if (TypeString='') or (Pos(': '+ClassStr,line)>0) then Inc(iBegCount); end else if (iBegCount>iEndCount) and (trim(line)='END') then Inc(iEndCount); if iBegCount>0 then Result := Result + list + #13#10; if (iBegCount>0) and (iBegCount=iEndCount) then Exit; end;end;procedure DeleteErrorLines(list:TStrings);var i:Integer; line:String;begin if list.Count=0 then Exit; i:=0; while i<list.Count do begin line := Trim(list); if Copy(line,1,2)='On' then list.Delete(i) else Inc(i); end;end;procedure ReadForm(aFrom : TComponent;aFileName :string='');varFrmStrings : TStrings;begin RegisterClass(TPersistentClass(aFrom.ClassType)); FrmStrings:=TStringlist.Create ; try FrmStrings.LoadFromFile(aFileName); while aFrom.ComponentCount>0 do aFrom.Components[0].Destroy ; aFrom:=StringToComponent(FrmStrings.Text,aFrom) finally FrmStrings.Free; end; UnRegisterClass(TPersistentClass(aFrom.ClassType));end;function LoadTextForm(FileName:String):TForm;var list:TStrings; FirstLine:String; iPos : Integer; Form : TForm;begin Result := nil; if FileExists(FileName)=False then Exit; Form := TForm.Create(Application); list := TStringList.Create; try list.LoadFromFile(FileName); if list.Count=0 then Exit; FirstLine := list[0]; iPos := Pos(': ',FirstLine); if iPos = 0 then //找不到': '，格式不对 Exit; list[0]:=Copy(FirstLine,1,iPos)+' TForm'; DeleteErrorLines(list); StringToComponent(list.Text,Form); Result := Form; except Form.Free; Result := nil; end; list.Free;end;function LoadTextForm2(FileName:String;out ErrMsg:string):TForm;var list:TStrings; FirstLine:String; iPos : Integer; Form : TForm;begin Result := nil; if FileExists(FileName)=False then begin ErrMsg := '无效的文件名！'; Exit; end; Form := TForm.Create(Application); list := TStringList.Create; try list.LoadFromFile(FileName); if list.Count=0 then Exit; FirstLine := list[0]; iPos := Pos(': ',FirstLine); if iPos = 0 then //找不到': '，格式不对 begin ErrMsg := '找不到'': ''，文件格式不对'; Exit; end; list[0]:=Copy(FirstLine,1,iPos)+' TForm'; DeleteErrorLines(list); StringToComponent(list.Text,Form); Result := Form; except on e:exception do begin Form.Free; Result := nil; ErrMsg := '读入文件错误:'+e.Message; end; end; list.Free;end;initializationbeginRegisterClasses([ TUnknown, TForm, TFont, // Standard TFrame, TMainMenu, TPopupMenu, TLabel, TEdit, TMemo, TButton, TCheckBox, TRadioButton, TListBox, TComboBox, TScrollBar, TGroupBox, TRadioGroup, TPanel, TActionList, // Sub-item TMenuItem, TAction, // System TTimer, TPaintBox, TMediaPlayer, TOleContainer, // Additional TBitBtn, TSpeedButton, TMaskEdit, TStringGrid, TDrawGrid, TImage, TShape, TBevel, TScrollBox, TCheckListBox, TSplitter, TStaticText, TControlBar, TApplicationEvents, TValueListEditor, TColorBox, TActionManager, TActionMainMenuBar, TActionToolBar, TXPColorMap, TStandardColorMap, TTwilightColorMap, TCustomizeDlg, // Win32 TTabControl, TPageControl, TImageList, TTrackBar, TProgressBar, TUpDown, THotKey, TAnimate, TDateTimePicker, TMonthCalendar, TTreeView, TListView, THeaderControl, TStatusBar, TToolBar, TCoolBar, TPageScroller, TComboBoxEx, // Sub-item TTabSheet, TToolButton, // Win 3.1 TDBLookupList, TDBLookupCombo, TTabSet, TOutline, TTabbedNotebook, TNotebook, THeader, TFileListBox, TDirectoryListBox, TDriveComboBox, TFilterComboBox, // Dialogs TOpenDialog, TSaveDialog, TOpenPictureDialog, TSavePictureDialog, TFontDialog, TColorDialog, TPrintDialog, TPrinterSetupDialog, TFindDialog, TReplaceDialog, TPageSetupDialog, // Samples TGauge, TColorGrid, TSpinButton, TSpinEdit, TDirectoryOutline, TCalendar, // Data Controls TDBGrid, TDBNavigator, TDBText, TDBEdit, TDBMemo, TDBImage, TDBListBox, TDBComboBox, TDBCheckBox, TDBRadioGroup, TDBLookupListBox, TDBLookupComboBox, TDBRichEdit, TDBCtrlGrid]);end;finalizationUnRegisterClasses([ TUnknown,TForm, TFont, // Standard TFrame, TMainMenu, TPopupMenu, TLabel, TEdit, TMemo, TButton, TCheckBox, TRadioButton, TListBox, TComboBox, TScrollBar, TGroupBox, TRadioGroup, TPanel, TActionList, // Sub-item TMenuItem, TAction, // System TTimer, TPaintBox, TMediaPlayer, TOleContainer, // Additional TBitBtn, TSpeedButton, TMaskEdit, TStringGrid, TDrawGrid, TImage, TShape, TBevel, TScrollBox, TCheckListBox, TSplitter, TStaticText, TControlBar, TApplicationEvents, TValueListEditor, TColorBox, TActionManager, TActionMainMenuBar, TActionToolBar, TXPColorMap, TStandardColorMap, TTwilightColorMap, TCustomizeDlg, // Win32 TTabControl, TPageControl, TImageList, TTrackBar, TProgressBar, TUpDown, THotKey, TAnimate, TDateTimePicker, TMonthCalendar, TTreeView, TListView, THeaderControl, TStatusBar, TToolBar, TCoolBar, TPageScroller, TComboBoxEx, // Sub-item TTabSheet, TToolButton, // Win 3.1 TDBLookupList, TDBLookupCombo, TTabSet, TOutline, TTabbedNotebook, TNotebook, THeader, TFileListBox, TDirectoryListBox, TDriveComboBox, TFilterComboBox, // Dialogs TOpenDialog, TSaveDialog, TOpenPictureDialog, TSavePictureDialog, TFontDialog, TColorDialog, TPrintDialog, TPrinterSetupDialog, TFindDialog, TReplaceDialog, TPageSetupDialog, // Samples TGauge, TColorGrid, TSpinButton, TSpinEdit, TDirectoryOutline, TCalendar, // Data Controls TDBGrid, TDBNavigator, TDBText, TDBEdit, TDBMemo, TDBImage, TDBListBox, TDBComboBox, TDBCheckBox, TDBRadioGroup, TDBLookupListBox, TDBLookupComboBox, TDBRichEdit, TDBCtrlGrid])end.
