S
szdnc
Unregistered / Unconfirmed
GUEST, unregistred user!
这里的事件如何写呢，请指点！
实际应用中，一个窗体几乎肯定会有事件处理函数，所以我们要达成第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，不能添加或删除控件，而且必须保留开发人员给定所有事件处理函数，不能修改函数名。
（Form1FRM.txt）
object Form1: TForm1
Left = 192
Top = 107
Width = 295
Height = 272
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Edit1: TEdit
Left = 72
Top = 40
Width = 121
Height = 21
TabOrder = 0
Text = 'Edit1'
end
object Edit2: TEdit
Left = 72
Top = 80
Width = 121
Height = 21
TabOrder = 1
Text = 'Edit2'
end
object Edit3: TEdit
Left = 72
Top = 128
Width = 121
Height = 21
TabOrder = 2
Text = 'Edit3'
end
end
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons, Grids, ComCtrls, DBCtrls, DBGrids,
dbcgrids;
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 = 29;//数组大小
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
AllCmpClass : TAllComponentClass; //存放控件类
implementation
{$R *.dfm}
//初始化可以解析的类，可随需要增加
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] := TTreeView;
AllCmpClass[29] := TListView;
end;
procedure RegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for i:=0 to RegisteredCompoentClassCount-1 do
RegisterClass(aAllCmpClass);
end;
procedure UnRegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for i:=0 to RegisteredCompoentClassCount-1 do
UnRegisterClass(aAllCmpClass);
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);
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='');
var
FrmStrings : TStrings;
begin
RegisterClass(TPersistentClass(aFrom.ClassType));
FrmStrings:=TStringlist.Create ;
try
if trim(aFileName)='' then FrmStrings.LoadFromFile(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;
procedure TForm1.Button1Click(Sender: TObject);
var
form:TForm;
begin
form:=LoadTextForm('Form1FRM.txt');
form.ShowModal;
end;
procedure TForm1.FormCreate(Sender: TObject);
//var
//form:TForm;
begin
//form:=LoadTextForm('Form1FRM.txt');
//ReadForm(self,'test.txt');
end;
initialization
begin
InitClassType(AllCmpClass);
RegisterAllClasses(AllCmpClass);
end;
finalization
UnRegisterAllClasses(AllCmpClass);
end.
实际应用中，一个窗体几乎肯定会有事件处理函数，所以我们要达成第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，不能添加或删除控件，而且必须保留开发人员给定所有事件处理函数，不能修改函数名。
（Form1FRM.txt）
object Form1: TForm1
Left = 192
Top = 107
Width = 295
Height = 272
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Edit1: TEdit
Left = 72
Top = 40
Width = 121
Height = 21
TabOrder = 0
Text = 'Edit1'
end
object Edit2: TEdit
Left = 72
Top = 80
Width = 121
Height = 21
TabOrder = 1
Text = 'Edit2'
end
object Edit3: TEdit
Left = 72
Top = 128
Width = 121
Height = 21
TabOrder = 2
Text = 'Edit3'
end
end
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons, Grids, ComCtrls, DBCtrls, DBGrids,
dbcgrids;
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 = 29;//数组大小
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
AllCmpClass : TAllComponentClass; //存放控件类
implementation
{$R *.dfm}
//初始化可以解析的类，可随需要增加
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] := TTreeView;
AllCmpClass[29] := TListView;
end;
procedure RegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for i:=0 to RegisteredCompoentClassCount-1 do
RegisterClass(aAllCmpClass);
end;
procedure UnRegisterAllClasses(aAllCmpClass:TAllComponentClass);
var
i:Integer;
begin
for i:=0 to RegisteredCompoentClassCount-1 do
UnRegisterClass(aAllCmpClass);
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);
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='');
var
FrmStrings : TStrings;
begin
RegisterClass(TPersistentClass(aFrom.ClassType));
FrmStrings:=TStringlist.Create ;
try
if trim(aFileName)='' then FrmStrings.LoadFromFile(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;
procedure TForm1.Button1Click(Sender: TObject);
var
form:TForm;
begin
form:=LoadTextForm('Form1FRM.txt');
form.ShowModal;
end;
procedure TForm1.FormCreate(Sender: TObject);
//var
//form:TForm;
begin
//form:=LoadTextForm('Form1FRM.txt');
//ReadForm(self,'test.txt');
end;
initialization
begin
InitClassType(AllCmpClass);
RegisterAllClasses(AllCmpClass);
end;
finalization
UnRegisterAllClasses(AllCmpClass);
end.