fmmain.pas

来自「多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术」· PAS 代码 · 共 107 行

unit fmMain;

interface

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

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    lbClasses: TListBox;
    GroupBox2: TGroupBox;
    lbInterfaces: TListBox;
    bbtnCheck: TBitBtn;
    BitBtn2: TBitBtn;
    procedure FormActivate(Sender: TObject);
    procedure lbClassesDblClick(Sender: TObject);
    procedure bbtnCheckClick(Sender: TObject);
  private
    { Private declarations }
    procedure FindClassInterfaces(aClass: TClass); 
    procedure FillClasses; 
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FillClasses;
var
  aClass : TClass;

  procedure FillInClassInfo(aClass : TClass);
  begin
    if (aClass <> nil) then
    begin
      lbClasses.Items.Add(aClass.ClassName);
      FillInClassInfo(aClass.ClassParent);
    end;
  end;
begin
  if (lbClasses.Items.Count = 0) then
  begin
    aClass := Self.ClassType;
    FillInClassInfo(aClass);
  end;
end;

procedure TForm1.FindClassInterfaces(aClass: TClass);
var
  idx : Integer;
  atbl : PInterfaceTable;
  aEntry : TInterfaceEntry;
begin
  atbl := aClass.GetInterfaceTable;

  if (atbl <> nil) then
  begin
    for idx := 0 to atbl.EntryCount - 1 do    // Iterate
    begin
      aEntry := atbl.Entries[idx];
      lbInterfaces.Items.Add(GuidToString(aEntry.IID));
    end;    // for
  end
  else
    lbInterfaces.Items.Add('此类未实现接口');
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  FillClasses;
end;

procedure TForm1.lbClassesDblClick(Sender: TObject);
var
  aClass : TClass;
  aStr : String;
begin
  if (lbClasses.ItemIndex <> -1) then
  begin
    lbInterfaces.Clear;
    aStr := lbClasses.Items[lbClasses.itemIndex];
    if (aStr <> 'TObject') then
    begin
      aClass := Self.ClassType;
      while (aClass.ClassName <> aStr) do
      begin
        aClass := aClass.ClassParent;
      end;    // while
      FindClassInterfaces(aClass);
    end;
  end;
end;

procedure TForm1.bbtnCheckClick(Sender: TObject);
begin
  lbClassesDblClick(Sender);
end;

end.