fmmain.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

unit fmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, ComCtrls, DB, DBTables, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    RadioButton1: TRadioButton;
    ListBox1: TListBox;
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    Database1: TDatabase;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    lbVMTs: TListBox;
    lbVMTContents: TListBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Button4: TButton;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure RadioButton1Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Memo1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private declarations }
    aClass : TClass;
    sClassName : String;

    procedure ShowVMTResult(const Msg: string);
    procedure ShowVMTEntry(const iDelta: Integer; pVMT: Pointer);
    procedure ShowVMTContent(aVMT: TClass);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  aClass := Self.Button1.ClassType;
  sClassName := 'TButton';
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  aClass := Self.CheckBox1.ClassType;
  sClassName := 'TCheckBox';
end;

procedure TForm1.RadioButton1Click(Sender: TObject);
begin
  aClass := Self.RadioButton1.ClassType;
  sClassName := 'TRadioButton';
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  aClass := Self.ListBox1.ClassType;
  sClassName := 'TListBox';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  aClass := Self.ClassType;
  sClassName := 'TForm1';
end;

procedure TForm1.Memo1Click(Sender: TObject);
begin
  aClass := Self.Memo1.ClassType;
  sClassName := 'TMemo';
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  aClass := Self.Database1.ClassType;
  sClassName := 'TDatabase';
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
  ShowVMTContent(aClass);
end;

const
  VMTOFFSET = 12;
  VMTDELTA = 4;

procedure TForm1.ShowVMTContent(aVMT: TClass);
var
  pVMT : Pointer;
  idx : Integer;
begin
  ShowVMTResult(sClassName + ' VMT表格地址 : ' + IntToStr(Integer(aVMT)) );
  pVMT := Pointer(aVMT);
  idx := VMTOFFSET;
  while (idx > vmtSelfPtr) do
  begin
    ShowVMTEntry(idx, pVMT);
    Dec(idx, VMTDELTA);
  end;    // while
end;

procedure TForm1.ShowVMTEntry(const iDelta: Integer; pVMT: Pointer);
var
  pResult : Pointer;
  Msg : String;

  procedure DoProcess(const sName : String);
  begin
    if (Assigned(pResult)) then
    begin
      Msg := Format('%s : %x', [sName, Integer(pResult)]);
      ShowVMTResult(Msg);
    end;
  end;

begin
  pResult := Pointer(Integer(pVMT) + iDelta);
  case iDelta of    //
    vmtCreateObject : DoProcess('vmtCreateObject');
    vmtRelease : DoProcess('vmtRelease');
    vmtAddRef : DoProcess('vmtAddRef');
    vmtQueryInterface : DoProcess('vmtQueryInterface');
    vmtDestroy : DoProcess('vmtDestroy');
    vmtFreeInstance : DoProcess('vmtFreeInstance');
    vmtNewInstance : DoProcess('vmtNewInstance');
    vmtDefaultHandler : DoProcess('vmtDefaultHandler');
    vmtDispatch : DoProcess('vmtDispatch');
    vmtBeforeDestruction : DoProcess('vmtBeforeDestruction');
    vmtAfterConstruction : DoProcess('vmtAfterConstruction');
    vmtSafeCallException : DoProcess('vmtSafeCallException');
    vmtParent : DoProcess('vmtParent');
    vmtInstanceSize : DoProcess('vmtInstanceSize');
    vmtClassName : DoProcess('vmtClassName');
    vmtDynamicTable : DoProcess('vmtDynamicTable');
    vmtMethodTable : DoProcess('vmtMethodTable');
    vmtFieldTable : DoProcess('vmtFieldTable');
    vmtTypeInfo : DoProcess('vmtTypeInfo');
    vmtInitTable : DoProcess('vmtInitTable');
    vmtAutoTable : DoProcess('vmtAutoTable');
    vmtIntfTable : DoProcess('vmtIntfTable');
    vmtSelfPtr : DoProcess('vmtSelfPtr');
  end;    // case
end;

procedure TForm1.ShowVMTResult(const Msg: string);
begin
  Self.lbVMTs.Items.Add(Msg);
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  aPnl : TPanel;
  aForm : TForm1;
begin
  aClass := aPnl.ClassType;
  sClassName := 'TPanel';
  ShowVMTContent(aClass);

  aPnl := TPanel.Create(Self);
  aClass := aPnl.ClassType;
  sClassName := 'TPanel';
  ShowVMTContent(aClass);
  FreeAndNil(aPnl);


end;

procedure TForm1.Button5Click(Sender: TObject);
var
  Msg : String;
  pVMT : Pointer;
begin
  Msg := Format('%s : %x', ['Self', Integer(Pointer(Self))]);
  ShowVMTResult(Msg);
  pVMT := Pointer(Integer(Pointer(Self)^) + vmtSelfPtr);
  Msg := Format('%s : %x', ['vmtSelfPtr', Integer(Pointer(pVMT))]);
  ShowVMTResult(Msg);
  pVMT := Pointer(Pointer(Integer(Pointer(Self)^) + vmtSelfPtr)^);
  Msg := Format('%s : %x', ['vmtSelfPtr', Integer(Pointer(pVMT))]);
  ShowVMTResult(Msg);
end;

end.