(*
功能：读取 Delphi 窗体文件，并显示设计时原样。
对于第三方控件，怎么替换为一个可显示的控件，显示位置，提示类名
* 2006-10-11 by liqj
*)
unit u_ReadDfmMainForm;
interface
uses
SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, StrUtils, Buttons,
ExtCtrls, ComCtrls, Graphics;
type
TfrmReadDfmMain = class(TForm)
btnLoad: TButton;
memPositionList: TMemo;
memNameList: TMemo;
dlgOpen: TOpenDialog;
memSource: TMemo;
btnConv: TButton;
btnExec: TButton;
btnExec_Source: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
chkAddHintInNoRegClass: TCheckBox;
chkAddHintInRegClass: TCheckBox;
procedure btnLoadClick(Sender: TObject);
procedure btnConvClick(Sender: TObject);
procedure btnExecClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
end;
// 未能注册的类替换为此类
TUnknown = class(TCustomControl)
public
procedure Paint;override;
published
property TabOrder;
property Align;
property Caption;
property Color;
property Popupmenu;
property ClientWidth;
property ClientHeight;
property Font;
property ShowHint;
end;
var
frmReadDfmMain: TfrmReadDfmMain;
implementation
uses
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, ShellCtrls, Chart, DBChart,
SHDocVw;
{$R *.dfm}
procedure TUnknown.Paint;
begin
inherited;
Canvas.Rectangle(0, 0, Width, Height); // 长方形
//Canvas.Font.Color := clRed;
Canvas.TextOut(2,2,Name);
end;
procedure TfrmReadDfmMain.btnLoadClick(Sender: TObject);
var
inStream,outStream :TMemoryStream;
iChar :Char;
sFileName :string;
begin
if dlgOpen.Execute then
sFileName := dlgOpen.FileName
else
Exit;
inStream := TMemoryStream.Create;
try
inStream.LoadFromFile(sFileName);
inStream.Position := 0;
inStream.Read(iChar,SizeOf(iChar));
inStream.Position := 0;
// 检查 dfm 文件格式：第一字节是 ['o','O','i','I',' ',#13,#11,#9] 则判定为文本格式
// 二进制格式一般为 255
// GExpert 的判断方法：(前三个字节为下面几个值表示是2进制)
// TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
// if (Buf[0] = $FF) and (Buf[1] = $0A) and (Buf[2] = $00) then
// 使用 Classes.TestStreamFormat(Stream) 函数判断也行 p9193
if not (iChar in ['o','O','i','I',' ',#13,#11,#9]) then
begin
outStream := TMemoryStream.Create;
try
ObjectResourceToText(inStream, outStream); // 二进制资源转成文本格式
outStream.Position := 0;
memSource.Lines.LoadFromStream(outStream);
finally
outStream.Free;
end;
end
else
memSource.Lines.LoadFromStream(inStream);
finally
inStream.Free;
end;
end;
procedure TfrmReadDfmMain.btnConvClick(Sender: TObject);
const
// 未注册组件过滤列表 -- 仅仅. 要全小写则比较时这个不用再转化
PropertyList : array [0..20] of string =
('top','left','width','height','taborder','align','caption','color',
'popupmenu','clientwidth','clientheight','cursor','hint','showhint',
'font.charset','font.color','font.height','font.name','font.style',
'menu','action');
// 已注册组件排除属性列表
NoPropertyList :array [0..1] of string =
('datasource','formstyle');
var
iIndex,iLen,iLineCount :integer;
sLine :string;
function FindCharIndex(piChar :Char):boolean;
begin
while (iIndex<=iLen) and (sLine[iIndex] <> piChar) do
Inc(iIndex);
Result := (iIndex<=iLen) and (sLine[iIndex] = piChar);
end;
function GetLevel :integer;
begin
Result := 0;
while (iIndex<=iLen) and (sLine[iIndex] = #32) do
begin
Inc(iIndex);
Inc(Result);
end;
if Result >0 then Result := Result div 2; // 2个空格为一个层次
end;
function InPropertyList(const psValue :string):boolean;
var
iLoop :integer;
begin
Result := False;
if psValue = '' then Exit;
for iLoop :=Low(PropertyList) to High(PropertyList) do
if PropertyList[iLoop] = psValue then break;
//ToDo: CompareText(S1,S2) =0 与直接比较那个快呢？,直接比较还有一边转成小写的操作
Result := iLoop <= High(PropertyList);
end;
function InNoPropertyList(const psValue :string):boolean;
var
iLoop :integer;
begin
Result := False;
if psValue = '' then Exit;
for iLoop :=Low(NoPropertyList) to High(NoPropertyList) do
if NoPropertyList[iLoop] = psValue then break;
Result := iLoop <= High(NoPropertyList);
end;
function FindStrOfLineCount(const psValue :string;var piIndex:integer):integer;
begin
Result := piIndex;
while (piIndex < iLineCount) and
(LowerCase(Trim(memSource.Lines[piIndex])) <> psValue) do
Inc(piIndex);
Result := piIndex - Result;
end; // Local
function GetPropertyName(const psValue :string):string;
var
iPos :integer;
begin
iPos := Pos('=',psValue);
if iPos >0 then
Result := Trim(Copy(psValue,1,iPos-1))
else
Result := '';
end;
var
iLoop, iOldIndex, iLevel :integer;
sFix_6, sValue, sName,sClassName, sProperty, sPropertyValue:string;
bIsForm{,bHasHint} : boolean;
CurClass :TPersistentClass;
begin // Main
memNameList.Lines.Clear; // 名称/类名 列表
memPositionList.Lines.Clear; // 位置信息
memNameList.Lines.Add('层： 名称 [类名](*表示不能识别)');
memNameList.Lines.BeginUpdate;
memPositionList.Lines.BeginUpdate;
try
// 外循环，开始添加*对象
iLoop := 0; // 当前行数
iLineCount := memSource.Lines.Count;
while iLoop < iLineCount do
begin
sLine := TrimRight(memSource.Lines[iLoop]); // 后缀不能有空格
iLen := Length(sLine);
iIndex := 1;
iLevel := GetLevel ; // 去前缀空格
sFix_6 := LowerCase(Copy(sLine,iIndex,6));
if (sFix_6 ='object') or (sFix_6 ='inline') or
(LowerCase(Copy(sLine,iIndex,9))= 'inherited')then
begin
//memPositionList.Lines.Add(memSource.Lines[iLoop]); // 对象定义，输出
if (sLine[iIndex+3] = 'h') or (sLine[iIndex+3] = 'H') then
iOldIndex := iIndex + 10
else
iOldIndex := iIndex + 7;
if FindCharIndex(':') then
begin
sName := Trim(Copy(sLine,iOldIndex,iIndex - iOldIndex));
sClassName := Trim(Copy(sLine,iIndex +1,iLen - iIndex))
end
else
begin
sName := 'Unknown_Name' + intToStr(iLoop);
sClassName := Trim(Copy(sLine,iIndex +1,iLen - iIndex));
end;
CurClass :=GetClass(sClassName);
if (CurClass<>nil) or (iLoop =0) then // 有注册的类或第一行(一般是 Form、DataModal)
begin
// 显示层次关系
memNameList.Lines.Add(Format('%2d： %s [%s]',[iLevel,sName,sClassName]));
bIsForm := (iLoop =0);// or (sClassName='TForm');
memPositionList.Lines.Add(memSource.Lines[iLoop]); // **对象定义，输出
if (iLoop=0) and // 强制提示
(chkAddHintInNoRegClass.Checked or chkAddHintInRegClass.Checked) then
memPositionList.Lines.Add(' ShowHint = True');
// else
// memPositionList.Lines.Add(StringOfChar(' ',iLevel*2)+ ' Hint = '''+ sName+'''#13#10'''+ sClassName + '''');
Inc(iLoop);
sFix_6 := LowerCase(Copy(Trim(memSource.Lines[iLoop]),1,6)); // 当是对象时 = object
// 仅从 TControl、TMenuItem 继承才有 Hint 属性 或第一个类 Form/DM
if chkAddHintInRegClass.Checked and
(
(CurClass = nil)
or
((CurClass<>nil) and
(CurClass.InheritsFrom(TControl)))
)
then // or CurClass.InheritsFrom(TMenuItem)) then
memPositionList.Lines.Add(StringOfChar(' ',iLevel*2)+
' Hint = ''Name='+ sName+'''#13#10''ClassName='+ sClassName + '''');
// 添加所属对象:仅注册类
while (iLoop < iLineCount) and
Not ((sFix_6 ='object') or (sFix_6 ='inline') or
(LowerCase(Copy(Trim(memSource.Lines[iLoop]),1,9))= 'inherited')) do
begin
// 未到结束，不是下一个对象定义,循环加已知组件的所有属性,事件不加
if Copy(sFix_6,1,2) <> 'on' then // 非事件，继续!!!
begin
sProperty := LowerCase(GetPropertyName(Trim(memSource.Lines[iLoop])));// 属性名称
if not InNoPropertyList(sProperty) then // 排除列表外,继续!
begin
if not bIsForm then
memPositionList.Lines.Add(memSource.Lines[iLoop]) // 非Form，加!!!
else if sProperty <> 'visible' then
memPositionList.Lines.Add(memSource.Lines[iLoop]); // Form不能放 visible.
end;
end;
Inc(iLoop);
sFix_6 := LowerCase(Copy(Trim(memSource.Lines[iLoop]),1,6));
end;
Continue;
end
else
begin
// 未注册的类，使用 TUnknown 类替换类名
// 显示层次关系 多一个*号表示不能识别
memNameList.Lines.Add(Format('%2d： %s [%s]*',[iLevel,sName,sClassName]));
if (sLine[iIndex+3] = 'h') or (sLine[iIndex+3] = 'H') then //
sValue := 'inherited ' + sName
else
sValue := sFix_6 +' '+ sName; // = object Name
// 组合未注册的类的源码对象定义
sValue := Format('%s%s : %s',[StringOfChar(' ',iLevel*2),sValue,'TUnknown']);
memPositionList.Lines.Add(sValue); // 对象定义!
if chkAddHintInNoRegClass.Checked then // 加入提示!
memPositionList.Lines.Add(StringOfChar(' ',iLevel*2)+
' Hint = ''Name='+ sName+'''#13#10''ClassName='+ sClassName + '*''');
end;
// 内循环，添加所属对象:仅未注册类、预定义部份
Inc(iLoop);
while (sLine <> 'end') and (iLoop < iLineCount) do
begin
sLine := memSource.Lines[iLoop];
iLevel := GetLevel;
sLine := LowerCase(Trim(sLine)); // 两边不要空格,并转为小写
iLen := Length(sLine);
iIndex := 1;
if sLine = 'end' then // 对象定义结束，输出
begin
memPositionList.Lines.Add(memSource.Lines[iLoop]);
Inc(iLoop);
while LowerCase(Trim(memSource.Lines[iLoop])) ='end' do // 加完所有一行是 end 的行
begin // 因为有嵌套部份!!!
memPositionList.Lines.Add(memSource.Lines[iLoop]);
Inc(iLoop);
end;
Continue;
end;
sFix_6 := LowerCase(Copy(sLine,iIndex,6));
// 包含对象，需要重新执行外循环
if (sFix_6 ='object') or (sFix_6 ='inline') or
(LowerCase(Copy(sLine,iIndex,9))= 'inherited')then
break;
if FindCharIndex('=') then // 是否有 属性 = 值 对!
begin
sProperty := Trim(Copy(sLine,1,iIndex -1));
if InPropertyList(sProperty) then // 属性名称为预定义，输出
memPositionList.Lines.Add(memSource.Lines[iLoop]);
sPropertyValue := Trim(Copy(sLine,iIndex +1,iLen - iIndex));
if sPropertyValue='<' then // 集合属性,跳过直到 end>行 例：<#13#10Item1#13#10Item#13#10end>
begin
FindStrOfLineCount('end>',iLoop);
end;
end;
Inc(iLoop);
end;
Continue;
end;
if sLine = 'end' then // 对象定义结束，输出
memPositionList.Lines.Add(memSource.Lines[iLoop]);
Inc(iLoop);
end;
finally
memPositionList.Lines.EndUpdate;
memNameList.Lines.EndUpdate;
end;
end;
procedure TfrmReadDfmMain.btnExecClick(Sender: TObject);
var
frmExec : TForm;
inStream, outStream :TMemoryStream;
begin
if Trim(memPositionList.Lines.Text)= '' then Exit;
frmExec := TForm.Create(nil);
try
inStream := TMemoryStream.Create;
outStream := TMemoryStream.Create;
try
if Sender = btnExec_Source then
memSource.Lines.SaveToStream(inStream)
else
memPositionList.Lines.SaveToStream(inStream);
inStream.Position := 0;
ObjectTextToResource(inStream,outStream); // 窗体定义 -> 资源
outStream.Position := 0;
OutStream.ReadComponentRes(frmExec); // 资源 -> 显示的窗体
finally
inStream.Free;
outStream.Free;
end;
frmExec.ShowModal;
finally
frmExec.Free;
end;
end;
procedure TfrmReadDfmMain.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
frmReadDfmMain := nil;
end;
initialization
// 注册自带类
RegisterClasses([
TUnknown, TForm, TFont, //TControl,
// Standard
TFrame, TMainMenu, TPopupMenu, TLabel, TEdit, TMemo, TButton,
TCheckBox, TRadioButton, TListBox, TComboBox, TScrollBar, TGroupBox,
TRadioGroup, TPanel, TActionList,
// Standard: Sub-item
TMenuItem, TAction,
// Additional
TBitBtn, TSpeedButton, TMaskEdit, TStringGrid, TDrawGrid, TImage,
TShape, TBevel, TScrollBox, TCheckListBox, TSplitter, TStaticText, TControlBar,
{TApplicationEvents,} TValueListEditor, TLabeledEdit, TColorBox, TChart,
TActionManager, TActionMainMenuBar,TActionToolBar, TXPColorMap, TStandardColorMap,
TTwilightColorMap, TCustomizeDlg,
// Win32
TTabControl, TPageControl, TImageList, TRichEdit, TTrackBar, TProgressBar, TUpDown, THotKey,
TAnimate, TDateTimePicker, TMonthCalendar, TTreeView, TListView, THeaderControl,
TStatusBar, TToolBar, TCoolBar, TPageScroller, TComboBoxEx,
// Win32: Sub-item
TTabSheet, TToolButton,
// System
{TTimer,} TPaintBox, TMediaPlayer,TOleContainer,
// Dialogs
{TOpenDialog, TSaveDialog, TOpenPictureDialog, TSavePictureDialog, TFontDialog,
TColorDialog, TPrintDialog, TPrinterSetupDialog, TFindDialog, TReplaceDialog,
TPageSetupDialog,}
// Win 3.1
TDBLookupList, TDBLookupCombo, TTabSet, TOutline, TTabbedNotebook, TNotebook,
THeader, TFileListBox, TDirectoryListBox, TDriveComboBox, TFilterComboBox,
// Samples
TGauge, TColorGrid, TSpinButton, TSpinEdit, TDirectoryOutline, TCalendar,
TShellTreeView, TShellComboBox, TShellListView, TScroller,
// Data Controls
TDBGrid, TDBNavigator, TDBText, TDBEdit, TDBMemo, TDBImage, TDBListBox,
TDBComboBox, TDBCheckBox, TDBRadioGroup, TDBLookupListBox, TDBLookupComboBox,
TDBRichEdit, TDBCtrlGrid, TDBChart,
// Other
// Internet
TWebBrowser
]);
end.
// 窗体
object frmReadDfmMain: TfrmReadDfmMain
Left = 94
Top = 43
Width = 889
Height = 606
Caption = 'frmMain'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnClose = FormClose
PixelsPerInch = 96
TextHeight = 12
object Label1: TLabel
Left = 80
Top = 32
Width = 90
Height = 12
Caption = 'dfm'#28304#25991#20214#20195#30721#65306
end
object Label2: TLabel
Left = 296
Top = 32
Width = 84
Height = 12
Caption = #32452#20214#21517#31216#21015#34920#65306
end
object Label3: TLabel
Left = 648
Top = 21
Width = 84
Height = 12
Caption = #36716#25442#32467#26524#20195#30721#65306
end
object memPositionList: TMemo
Left = 520
Top = 40
Width = 353
Height = 521
Align = alCustom
ScrollBars = ssBoth
TabOrder = 1
end
object memNameList: TMemo
Left = 296
Top = 48
Width = 217
Height = 513
Align = alCustom
Lines.Strings = (
'memNameList')
ScrollBars = ssBoth
TabOrder = 2
end
object btnLoad: TButton
Left = 8
Top = 3
Width = 89
Height = 25
Caption = #25171#24320'dfm'#25991#20214
TabOrder = 0
OnClick = btnLoadClick
end
object memSource: TMemo
Left = 0
Top = 48
Width = 281
Height = 513
Hint = '|'#25105#13#10#20182
Lines.Strings = (
'memSource')
ScrollBars = ssBoth
TabOrder = 3
end
object btnConv: TButton
Left = 111
Top = 3
Width = 75
Height = 25
Caption = #36716#25442
TabOrder = 4
OnClick = btnConvClick
end
object btnExec: TButton
Left = 200
Top = 2
Width = 75
Height = 25
Caption = #25191#34892#32467#26524
TabOrder = 5
OnClick = btnExecClick
end
object btnExec_Source: TButton
Left = 288
Top = 2
Width = 113
Height = 25
Caption = 'btnExec_Source'
TabOrder = 6
Visible = False
OnClick = btnExecClick
end
object chkAddHintInNoRegClass: TCheckBox
Left = 416
Top = 8
Width = 153
Height = 17
Caption = #21152#25552#31034'('#20165#26410#33021#35782#21035#30340#31867')'
TabOrder = 7
end
object chkAddHintInRegClass: TCheckBox
Left = 416
Top = 24
Width = 153
Height = 17
Caption = #21152#25552#31034'('#20165#33021#35782#21035#30340#31867')'
TabOrder = 8
end
object dlgOpen: TOpenDialog
DefaultExt = '*.dfm'
Filter = 'Delphi Form(*.dfm)|*.dfm'
Left = 32
Top = 56
end
end
