Delphi的“动态窗体”技术实际应用  
日期：2005年6月1日   作者：On2008   人气：613   查看:[大字体   中字体   小字体]    
在Delphi可视化设计环境中，允许程序员在代码编辑器中以文本的方式浏览和修改DFM文件内容。当用File/Open命令直接打开DFM文件或者选择窗体设计窗口的弹出式菜单上的View   as   Text命令时，就会在编辑器中出现文本形式的信息。在一些资料中将这种文本形式称之为窗体设计脚本。Delphi提供的这种脚本编辑功能是对Delphi可视化设计的一大补充。当然这个脚本编辑能力是有限制的，比方说不能在脚本任意地添加和删除部件，因为代码和DFM脚本是紧密相连的，任意添加和修改会导致不一致性。但在动态生成的DFM文件中，就不存在这一限制。
　　实际上，DFM文件内容是二进制数据，它的脚本是经过Delphi开发环境自动转化的，而且Delphi   VCL中的Classes库单元提供了在二进制流中的文件DFM和它的脚本之相互转化的过程。它们是ObjectBinaryToText和ObjectTextToBinary、ObjectResourceToText和ObjectTextToResource。
　　ObjectBinaryToText过程将二进制流中存储的部件转化为基于文本的表现形式，这样就可以用文本处理函数进行处理，还可以用文本编辑器进行查找和替代操作，最后可以将文本再转化成二进制流中的部件。
　　ObjectTextToBinary过程执行的功能与ObjectBinaryToText相反，将TXT文件转换为二进制流中的部件，而且只要TXT文件内容的书写符合DFM脚本语法，ObjectTextToBinary可将任何程序生成的TXT文件转换为部件，这一功能也为DFM文件的动态生成和编辑奠定了基础。

如何在运行过程中将本窗体保存成一个文本格式的.dfm文件？
zswang(伴水)　(2001-11-21   9:52:59)   得0分
function   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;   {   ComponentToString   }
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;   {   StringToComponent   }
　
回复人：　zswang(伴水)　(2001-11-21   9:58:13)   得0分
procedure   TForm1.Button2Click(Sender:   TObject);
begin
StringToComponent(
'object   Label1:   TLabel '#13#10   +
'   Left   =   232 '#13#10   +
'   Top   =   56 '#13#10   +
'   Width   =   26 '#13#10   +
'   Height   =   13 '#13#10   +
'   Caption   =   #20320#22909 '#13#10   +
'   Font.Charset   =   GB2312_CHARSET '#13#10   +
'   Font.Color   =   clRed '#13#10   +
'   Font.Height   =   -13 '#13#10   +
'   Font.Name   =   #23435#20307 '#13#10   +
'   Font.Style   =   [] '#13#10   +
'   ParentFont   =   False '#13#10   +
'end '#13#10,   Label1);
end;
//要注册类
＝＝end＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
好了，理解了上面的这段文字，一些朋友就会自然想到，利用这几个函数应该可以弄出点有用的东西出来，我就弄出了一点应用，并全面应用到了项目中，现在我来给大家完整描述出来：
首先我要求我的程序有如下能力：
1.   我的程序的窗体是可以动态替换的，不用编译Exe，只要替换一个DFM窗体设计脚本就可以了（当然，你可以重新包装一下这个DFM文件，比如换成txt后缀名等）。
2.   我可以预览所有的DFM文件，让它变成实际的Form察看。
不要小看这两点，在很多情况下，这意义非常重大，举几个例子①开发阶段，可以把界面设计和程序设计完全分开，分工进行②现场维护时，有些界面的调整和功能设置不需要再找源代码到Delphi下去编译一遍了，老出差做Mis类的朋友应该能从这点体会出好处③某些功能界面的升级简单了不少，只要让用户下载一个DFM文件覆盖原来的就可以了。
好，不费话了，下面详细说明怎么达到以上两点要求。
显然我们要让一段文本变成一个Form，那么就用这个函数：
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;
但是，所有的Class必须是注册过的，例如，如下的Form1FRM.DFM文件
object   Form1:   TForm1
Left   =   222
Top   =   168
Width   =   485
Height   =   290
Caption   =   'Form1 '
Color   =   clBtnFace
Font.Charset   =   DEFAULT_CHARSET
Font.Color   =   clWindowText
Font.Height   =   -11
Font.Name   =   'MS   Sans   Serif '
Font.Style   =   []
OldCreateOrder   =   False
PixelsPerInch   =   96
TextHeight   =   13
object   Panel1:   TPanel
Left   =   0
Top   =   0
Width   =   477
Height   =   33
Align   =   alTop
TabOrder   =   0
object   BitBtn1:   TBitBtn
Left   =   4
Top   =   4
Width   =   75
Height   =   25
Caption   =   'OK '
TabOrder   =   0
end
end
object   Memo1:   TMemo
Left   =   0
Top   =   33
Width   =   477
Height   =   230
Align   =   alClient
TabOrder   =   1
end
end
你应该这么使用，
var   list:TstringList;form:TForm
…
list.Lines.LoadFromFile(‘Form1FRM.DFM’);
RegisterClass(TForm1);
RegisterClass(TPanel);
RegisterClass(TBitBtn);
RegisterClass(TMemo);
form   :=   StringToComponent(list.Lines.Text,nil);
form.ShowModal();
…
这样就能显示出一个窗体了。
但是这有个问题，Delphi自带的VCL控件是固定的，用RegisterClass（…）注册一遍没有问题，可TForm1不是，如果连TForm1都要注册的话，就无法达成第2点要求。我们可以变通一下，因为所有的Form都是从Tform继承的，所以，应该都可以用注册Tform来取代，因此，有了下面这样一个函数：
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;
原理就是读入DFM文件后把窗体的类别偷换成Tform。其中还有一个函数：
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[i]);
if   Copy(line,1,2)= 'On '   then
list.Delete(i)
else
Inc(i);
end;
end;
这个函数是把凡是含有“On”开头的行删除，应为在Delphi中，所有控件的事件都是以“On”开头，删除了这样的行，就能保证StringToComponent(list.Text,Form);不出错，用以上的两个函数就可以写一个DFM窗体察看器了，到目前为止，我还没有搜到哪个人发布了DFM窗体察看器。这样我们就完成了第2个要求。

对我有用[0]丢个板砖[0]引用举报管理TOP精华推荐：想做一个所见即所得的html编辑器 谁有这方面技术资料 谢谢了

xthmpro_cn
([可人])

等　级：

#5楼 得分：0回复于：2005-06-27 08:57:54实际应用中，一个窗体几乎肯定会有事件处理函数，所以我们要达成第1个要求。我这儿提供了两个方案，各有优缺点：
方案一：
程序员在开发时，在窗体的FormCreate（…）中，用LoadTextForm（…）生成窗体文件，然后把窗体上的控件全部移到本窗体上，最后查找窗体上的控件，动态设置事件处理函数。这个方法要求有一套好的控件命名规则，而且开发比较烦琐，享受不到Delphi的IDE所见即所得，自动生成事件关联代码的好处了。不过对Form文件的制作人员限制很小，他们可以直接用Delphi来制作窗体。
方案二：
用这个函数
procedure   ReadForm(aFrom   :   TComponent;aFileName   :string= ' ');
var
FrmStrings   :   TStrings;
begin
RegisterClass(TPersistentClass(aFrom.ClassType));
FrmStrings:=TStringlist.Create   ;
try
if   trim(aFileName)= ' '   then   FrmStrings.LoadFromFile(   gsPathInfo+ '\ '+aFrom.Name+ '.txt ')
else   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;
在FormCreate中调用ReadForm（self，…）。
这个方案没有第一个方案的限制，但是要求开发人员必须先完成一个完整的Form文件交给Form文件制作人员，   Form文件的制作人员不能修改控件的name，不能添加或删除控件，而且必须保留开发人员给定所有事件处理函数，不能修改函数名。不过很多问题可以写一个Form编辑器来保证不出问题。
具体代码就不写了。
我想，肯定还有跟好的方案来解决动态窗体的问题，希望大家讨论。
（以上代码使用Delphi6编写）
最后，我给出一个我实际项目中的有关动态窗体的函数的Unit
{*****************************************
模块编号：J001DfmFunc
模块名称：Dfm窗体函数集单元
作者：刘爱军
建立日期：2002年12月2日
最后修改日期：
说明：本Unit包含了一些函数，用于根据Delphi窗体文件格式的文件动态创建窗体
*******************************************}

unit   J001DfmFunc;

interface

uses
Windows,   Messages,   SysUtils,   Variants,   Classes,   Graphics,   Controls,   Forms,
Dialogs,   ExtCtrls,   DBCtrls,   Grids,   DBGrids,   Buttons,   StdCtrls,
ComCtrls,dbcgrids,   buttonComps,Tabs,QryGlobal;

type
TAllComponentClass   =   Array   of   TPersistentClass;

procedure   InitClassType(ClassArray:TAllComponentClass);

function   ComponentToString(Component:   TComponent):   string;
function   StringToComponent(Value:   string;   Instance:TComponent):   TComponent;
procedure   RegisterAllClasses(aAllCmpClass:TAllComponentClass);
procedure   UnRegisterAllClasses(aAllCmpClass:TAllComponentClass);
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= ' ');
const
RegisteredCompoentClassCount   =   32;//数组大小

var
AllCmpClass   :   TAllComponentClass;   //存放控件类

implementation

//初始化可以解析的类，可随需要增加
procedure   InitClassType(ClassArray:TAllComponentClass);
begin
SetLength(AllCmpClass,RegisteredCompoentClassCount);
AllCmpClass[0]   :=   TForm;
AllCmpClass[1]   :=   TGroupBox;
AllCmpClass[2]   :=   TPanel;
AllCmpClass[3]   :=   TScrollBox;
AllCmpClass[4]   :=   TLabel;
AllCmpClass[5]   :=   TButton;
AllCmpClass[6]   :=   TBitBtn;
AllCmpClass[7]   :=   TSpeedButton;
AllCmpClass[8]   :=   TStringGrid;
AllCmpClass[9]   :=   TImage;
AllCmpClass[10]   :=   TBevel;
AllCmpClass[11]   :=   TStaticText;
AllCmpClass[12]   :=   TTabControl;
AllCmpClass[13]   :=   TPageControl;
AllCmpClass[14]   :=   TTabSheet;
AllCmpClass[15]   :=   TDBNavigator;
AllCmpClass[16]   :=   TDBText;
AllCmpClass[17]   :=   TDBEdit;
AllCmpClass[18]   :=   TDBMemo;
AllCmpClass[19]   :=   TDBGrid;
AllCmpClass[20]   :=   TDBCtrlGrid;
AllCmpClass[21]   :=   TMemo;
AllCmpClass[22]   :=   TSplitter;
AllCmpClass[23]   :=   TCheckBox;
AllCmpClass[24]   :=   TEdit;
AllCmpClass[25]   :=   TListBox;
AllCmpClass[26]   :=   TComboBox;
AllCmpClass[27]   :=   TDateTimePicker;
AllCmpClass[28]   :=   TImageButton;
AllCmpClass[29]   :=   TTabSet;
AllCmpClass[30]   :=   TTreeView;
AllCmpClass[31]   :=   TListView;

end;
 
 
对我有用[0]丢个板砖[0]引用举报管理TOP精华推荐：这样算不算线程死锁状态

xthmpro_cn
([可人])

等　级：

#6楼 得分：0回复于：2005-06-27 08:58:14procedure   RegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for   i:=0   to   RegisteredCompoentClassCount-1   do
RegisterClass(aAllCmpClass[i]);
end;

procedure   UnRegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for   i:=0   to   RegisteredCompoentClassCount-1   do
UnRegisterClass(aAllCmpClass[i]);
end;

function   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[i]);
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[i]   +   #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[i]);
if   Copy(line,1,2)= 'On '   then
list.Delete(i)
else
Inc(i);
end;
end;
procedure   ReadForm(aFrom   :   TComponent;aFileName   :string= ' ');
var
FrmStrings   :   TStrings;
begin
RegisterClass(TPersistentClass(aFrom.ClassType));
FrmStrings:=TStringlist.Create   ;
try
if   trim(aFileName)= ' '   then   FrmStrings.LoadFromFile(   gsPathInfo+ '\ '+aFrom.Name+ '.txt ')
else   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;

initialization
begin
InitClassType(AllCmpClass);
RegisterAllClasses(AllCmpClass);
end;
finalization
UnRegisterAllClasses(AllCmpClass);
end.