ureader.pas

动态修改delphi窗口

// 代码比较简单，主要原理参考cnPack上的DFM Viewer v0.1
// 在原功能基础上，增加了对Inherited的窗体的显示功能
// 如果要显示的窗体中有本单元未包括的控件、或者自定义的Frame，请在本单元中注册才可使用
// 未对不指明组件做处理，需要处理可以参考 DFM Viewer v0.1
// 弹出查找基窗体的对话框时，如果选择基窗体错误或者未选择，程序会报错
// 具体使用时，可人为建一个基类窗体的对照关系，避免因选择错误导致异常
// [e-mail]
unit uReader;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, DBCtrls, Grids, DBGrids, Buttons, StdCtrls, ComCtrls, dbcgrids,
  Tabs, Menus, ActnList, MPlayer, OleCtnrs, Mask,CheckLst, AppEvnts, Outline,
  ActnMan, ValEdit, ActnCtrls, ActnColorMaps, dblookup,ExtDlgs, Gauges, ColorGrd, Spin,
  ActnMenus, CustomizeDlg, TabNotBk, FileCtrl, DirOutln, Calendar;

type 
  TAllComponentClass = array of TPersistentClass;

  procedure InitClassType(ClassArray:TAllComponentClass); 
  procedure RegisterAllClasses(aAllCmpClass:TAllComponentClass); 
  procedure UnRegisterAllClasses(aAllCmpClass:TAllComponentClass); 

  procedure ReadFirst(AFileName: string; var AFormStr: TStringList);
  procedure ReadForm(AFileName: string; var AFormHead, AFormBody: TStringList);
  function ShowForm(AFileName: string): TForm;

const
  RegisteredCompoentClassCount = 109;//数组大小

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

implementation

//初始化可以解析的类，可随需要增加 
procedure InitClassType(ClassArray:TAllComponentClass); 
begin 
  SetLength(AllCmpClass,RegisteredCompoentClassCount);

  AllCmpClass[0] := TForm;
  AllCmpClass[1] := TFont;
  // Standard
  AllCmpClass[2] := TFrame;
  AllCmpClass[3] := TMainMenu;
  AllCmpClass[4] := TPopupMenu;
  AllCmpClass[5] := TLabel;
  AllCmpClass[6] := TEdit;
  AllCmpClass[7] := TMemo;
  AllCmpClass[8] := TButton;
  AllCmpClass[9] := TCheckBox;
  AllCmpClass[10] := TRadioButton;
  AllCmpClass[11] := TListBox;
  AllCmpClass[12] := TComboBox;
  AllCmpClass[13] := TScrollBar;
  AllCmpClass[14] := TGroupBox;
  AllCmpClass[15] := TRadioGroup;
  AllCmpClass[16] := TPanel;
  AllCmpClass[17] := TActionList;
  // Sub-item
  AllCmpClass[18] := TMenuItem;
  AllCmpClass[19] := TAction;
  // System
  AllCmpClass[20] := TTimer;
  AllCmpClass[21] := TPaintBox;
  AllCmpClass[22] := TMediaPlayer;
  AllCmpClass[23] := TOleContainer;
  // Additional
  AllCmpClass[24] := TBitBtn;
  AllCmpClass[25] := TSpeedButton;
  AllCmpClass[26] := TMaskEdit;
  AllCmpClass[27] := TStringGrid;
  AllCmpClass[28] := TDrawGrid;
  AllCmpClass[29] := TImage;
  AllCmpClass[30] := TShape;
  AllCmpClass[31] := TBevel;
  AllCmpClass[32] := TScrollBox;
  AllCmpClass[33] := TCheckListBox;
  AllCmpClass[34] := TSplitter;
  AllCmpClass[35] := TStaticText;
  AllCmpClass[36] := TControlBar;
  AllCmpClass[37] := TApplicationEvents;
  AllCmpClass[38] := TValueListEditor;
  AllCmpClass[39] := TColorBox;
  AllCmpClass[40] := TActionManager;
  AllCmpClass[41] := TActionMainMenuBar;
  AllCmpClass[42] := TActionToolBar;
  AllCmpClass[43] := TXPColorMap;
  AllCmpClass[44] := TStandardColorMap;
  AllCmpClass[45] := TTwilightColorMap;
  AllCmpClass[46] := TCustomizeDlg;
  // Win32
  AllCmpClass[47] := TTabControl;
  AllCmpClass[48] := TPageControl;
  AllCmpClass[49] := TImageList;
  AllCmpClass[50] := TTrackBar;
  AllCmpClass[51] := TProgressBar;
  AllCmpClass[52] := TUpDown;
  AllCmpClass[53] := THotKey;
  AllCmpClass[54] := TAnimate;
  AllCmpClass[55] := TDateTimePicker;
  AllCmpClass[56] := TMonthCalendar;
  AllCmpClass[57] := TTreeView;
  AllCmpClass[58] := TListView;
  AllCmpClass[59] := THeaderControl;
  AllCmpClass[60] := TStatusBar;
  AllCmpClass[61] := TToolBar;
  AllCmpClass[62] := TCoolBar;
  AllCmpClass[63] := TPageScroller;
  AllCmpClass[64] := TComboBoxEx;
  // Sub-item
  AllCmpClass[65] := TTabSheet;
  AllCmpClass[66] := TToolButton;
  // Win 3.1
  AllCmpClass[67] := TDBLookupList;
  AllCmpClass[68] := TDBLookupCombo;
  AllCmpClass[69] := TTabSet;
  AllCmpClass[70] := TOutline;
  AllCmpClass[71] := TTabbedNotebook;
  AllCmpClass[72] := TNotebook;
  AllCmpClass[73] := THeader;
  AllCmpClass[74] := TFileListBox;
  AllCmpClass[75] := TDirectoryListBox;
  AllCmpClass[76] := TDriveComboBox;
  AllCmpClass[77] := TFilterComboBox;
  // Dialogs
  AllCmpClass[78] := TOpenDialog;
  AllCmpClass[79] := TSaveDialog;
  AllCmpClass[80] := TOpenPictureDialog;
  AllCmpClass[81] := TSavePictureDialog;
  AllCmpClass[82] := TFontDialog;
  AllCmpClass[83] := TColorDialog;
  AllCmpClass[84] := TPrintDialog;
  AllCmpClass[85] := TPrinterSetupDialog;
  AllCmpClass[86] := TFindDialog;
  AllCmpClass[87] := TReplaceDialog;
  AllCmpClass[88] := TPageSetupDialog;
  // Samples
  AllCmpClass[89] := TGauge;
  AllCmpClass[90] := TColorGrid;
  AllCmpClass[91] := TSpinButton;
  AllCmpClass[92] := TSpinEdit;
  AllCmpClass[93] := TDirectoryOutline;
  AllCmpClass[94] := TCalendar;
  // Data Controls
  AllCmpClass[95] := TDBGrid;
  AllCmpClass[96] := TDBNavigator;
  AllCmpClass[97] := TDBText;
  AllCmpClass[98] := TDBEdit;
  AllCmpClass[99] := TDBMemo;
  AllCmpClass[100] := TDBImage;
  AllCmpClass[101] := TDBListBox;
  AllCmpClass[102] := TDBComboBox;
  AllCmpClass[103] := TDBCheckBox;
  AllCmpClass[104] := TDBRadioGroup;
  AllCmpClass[105] := TDBLookupListBox;
  AllCmpClass[106] := TDBLookupComboBox;
  AllCmpClass[107] := TDBRichEdit;
  AllCmpClass[108] := TDBCtrlGrid;
end;

procedure 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; 

procedure ReadFirst(AFileName: string; var AFormStr: TStringList);
var
  dfmList: TStringList;
  strObject: array[1..6] of char;
  strInherited: array[1..9] of Char;
  InStream, OutStream: TMemoryStream;
begin
  InStream:= TMemoryStream.Create;
  OutStream:= TMemoryStream.Create;
  dfmList := TStringList.Create;
  try
    InStream.LoadFromFile(AFileName);
    InStream.Seek(0, soFromBeginning);

    InStream.ReadBuffer(strObject, 6);
    InStream.Seek(0, soFromBeginning);

    InStream.ReadBuffer(strInherited, 9);
    InStream.Seek(0, soFromBeginning);

    if (LowerCase(strObject) <> 'object') and (LowerCase(strInherited) <> 'inherited')  then  // bin format
    begin
      ObjectResourceToText(InStream, OutStream);
      InStream.Clear;
      InStream.LoadFromStream(OutStream);
      InStream.Seek(0, 0);
      OutStream.Clear;
    end;

    dfmList.LoadFromStream(InStream);
    AFormStr.Add(dfmList.Strings[0]);    
  finally
    FreeAndNil(InStream);
    FreeAndNil(OutStream);
    FreeAndNil(dfmList);
  end;
end;

procedure ReadForm(AFileName: string; var AFormHead, AFormBody: TStringList);
var
  i: Integer;
  tmpStr: string;
  IsHead: Boolean;
  dfmList: TStringList;
  strObject: array[1..6] of char;
  strInherited: array[1..9] of Char;
  InStream, OutStream: TMemoryStream;
begin
  // 判断当前Form是否是继承后的，是则先加载父类窗体，否则读取当前Form，然后写入列表
  InStream := TMemoryStream.Create;
  OutStream:= TMemoryStream.Create;
  dfmList := TStringList.Create;
  try
    InStream.LoadFromFile(AFileName);
    InStream.Seek(0, soFromBeginning);

    InStream.ReadBuffer(strObject, 6);
    InStream.Seek(0, soFromBeginning);

    InStream.ReadBuffer(strInherited, 9);
    InStream.Seek(0, soFromBeginning);

    // 暂时假设dfm文件都不是二进制
    if AnsiSameText(strInherited, 'inherited') then
    begin
      with TOpenDialog.Create(nil) do
      try
        Title := '请选择当前窗体的父窗体';
        Filter := 'dfm|*.dfm';
        DefaultExt := '*.dfm';
        if Execute then
          ReadForm(FileName, AFormHead, AFormBody);
      finally
        Free;
      end;
    end;

    if (LowerCase(strObject) <> 'object') and (LowerCase(strInherited) <> 'inherited')  then  // bin format
    begin
      ObjectResourceToText(InStream, OutStream);
      InStream.Clear;
      InStream.LoadFromStream(OutStream);
      InStream.Seek(0, 0);
      OutStream.Clear;
    end;
    
    dfmList.LoadFromStream(InStream);

    // 取出第一行和最后一行中间的内容
    IsHead := True;
    for i:= 1 to dfmList.Count - 2 do
    begin
      tmpStr := Trim(dfmList.Strings[i]);
      IsHead := IsHead and ( LowerCase(Copy(tmpStr, 1, 6)) <> 'object' ) and ( LowerCase(Copy(tmpStr, 1, 9)) <> 'inherited' );

      if ( LowerCase( Copy(tmpStr, 1, 2) ) = 'on' ) then
        Continue;

      // Head和Body的内容分开存放
      if IsHead then
      begin
        AFormHead.Add(dfmList.Strings[i])
      end else
      begin
        AFormBody.Add(dfmList.Strings[i]);
      end;
    end;
  finally
    FreeAndNil(InStream);
    FreeAndNil(OutStream);
    FreeAndNil(dfmList);
  end;
end;

function ShowForm(AFileName: string): TForm;
var
  InStream, OutStream: TMemoryStream;
  dfmHead, dfmBody, dfmList: TStringList;
begin
  Result := nil;
  if not FileExists(AFileName) then Exit;

  dfmHead := TStringList.Create;
  dfmBody := TStringList.Create;
  dfmList := TStringList.Create;
  InStream := TMemoryStream.Create;
  OutStream := TMemoryStream.Create;
  try
    ReadFirst(AFileName, dfmList);
    ReadForm(AFileName, dfmHead, dfmBody);
    dfmList.AddStrings(dfmHead);
    dfmList.AddStrings(dfmBody);
    dfmList.Add('end');

    dfmList.SaveToStream(InStream);
    InStream.Seek(0, soFromBeginning);
    ObjectTextToResource(InStream, OutStream);
    OutStream.Seek(0, soFromBeginning);

    Result := TForm.Create(Application);
    OutStream.ReadComponentRes(Result);
  finally
    FreeAndNil(dfmHead);
    FreeAndNil(dfmBody);
    FreeAndNil(dfmList);
    FreeAndNil(InStream);
    FreeAndNil(OutStream);
  end;
end;

initialization 
begin 
  InitClassType(AllCmpClass); 
  RegisterAllClasses(AllCmpClass); 
end;

finalization
  UnRegisterAllClasses(AllCmpClass);
end.