5

对于这个问题，我仍然没有找到真正令人满意的答案，现在正在考虑推出自己的答案。我有 ModelMaker 和 GExperts，似乎都没有加载我正在寻找的综合类层次结构。同样，我不认为 DevExpress 的人会分叉 CDK 代码，该代码编译完整的类列表以继承... ;-)

所以...

如果我只想为所有注册的组件类（或者甚至包括非组件的所有类，如果这同样容易/可能的话）构建一个自引用表，那么最好的方法是什么？

注意：我真的不需要属性/方法细节；只是一个完整的类名（和父名）列表，我可以将其存储到表中并放入树视图中。但是，除此之外的任何内容都非常受欢迎作为奖励信息。:-)

稍后更新：

一个答案出现在我关于 SO 的“最近”部分，但不是这里的问题（也许他们删除了它？），是这样的：

“你可能想看看组件搜索的代码，它可能会帮助你枚举所有已安装的组件。”

该代码可用吗？是这样，它藏在哪里？学习会很有趣。

4

3 回答 3

5

不幸的是，实现 RegisterClass 机制的代码隐藏在 Classes implementation 部分。

如果您需要它来获取 IDE 中安装的组件列表，您可以编写一个设计包，将其安装到 IDE 中并在 ToolsAPI 单元中使用 IOTAPackageServices。这将为您提供已安装软件包及其组件的列表。

注意：您必须将 designide.dcp 添加到您的 'requires' 子句才能使用 Delphi 的内部单元，如 ToolsAPI。

更多的工作，但更通用的方法是枚举所有加载的模块。您可以在包模块上调用 GetPackageInfo (SysUtils) 以枚举包含的单元名称和所需的包。但是，这不会为您提供包中包含的类的列表。

您可以枚举包的导出函数列表（例如，在JCL中使用 TJclPeImage ）并搜索那些命名如下：

@<unit_name>@<class_name>@

例如：'@System@TObject@'。

通过使用函数名称调用 GetProcAddress，您可以获得 TClass 引用。从那里您可以使用 ClassParent 遍历层次结构。通过这种方式，您可以枚举在运行使用运行时包编译的 Delphi 可执行文件的进程中加载​​的所有包中的所有类（Delphi IDE 也是如此）。

于 2009-04-18T12:33:10.813 回答
4

另一个想法是扫描导出函数列表顶部的类型信息，以便您可以跳过进一步枚举。类型信息以前缀“@$xp$”开头的名称导出。这是一个例子：

unit PackageUtils;

interface

uses
  Windows, Classes, SysUtils, Contnrs, TypInfo;

type
  TDelphiPackageList = class;
  TDelphiPackage = class;

  TDelphiProcess = class
  private
    FPackages: TDelphiPackageList;

    function GetPackageCount: Integer;
    function GetPackages(Index: Integer): TDelphiPackage;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Clear; virtual;
    function FindPackage(Handle: HMODULE): TDelphiPackage;
    procedure Reload; virtual;

    property PackageCount: Integer read GetPackageCount;
    property Packages[Index: Integer]: TDelphiPackage read GetPackages;
  end;

  TDelphiPackageList = class(TObjectList)
  protected
    function GetItem(Index: Integer): TDelphiPackage;
    procedure SetItem(Index: Integer; APackage: TDelphiPackage);
  public
    function Add(APackage: TDelphiPackage): Integer; 
    function Extract(APackage: TDelphiPackage): TDelphiPackage;
    function Remove(APackage: TDelphiPackage): Integer;
    function IndexOf(APackage: TDelphiPackage): Integer;
    procedure Insert(Index: Integer; APackage: TDelphiPackage);
    function First: TDelphiPackage;
    function Last: TDelphiPackage;

    property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
  end;

  TDelphiPackage = class
  private
    FHandle: THandle;
    FInfoTable: Pointer;
    FTypeInfos: TList;

    procedure CheckInfoTable;
    procedure CheckTypeInfos;
    function GetDescription: string;
    function GetFileName: string;
    function GetInfoName(NameType: TNameType; Index: Integer): string;
    function GetShortName: string;
    function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
    function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
  public
    constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
    destructor Destroy; override;

    property Description: string read GetDescription;
    property FileName: string read GetFileName;
    property Handle: THandle read FHandle;
    property ShortName: string read GetShortName;
    property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
    property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
  end;

implementation

uses
  RTLConsts, SysConst,
  PSAPI, ImageHlp;

{ Package info structures copied from SysUtils.pas }

type
  PPkgName = ^TPkgName;
  TPkgName = packed record
    HashCode: Byte;
    Name: array[0..255] of Char;
  end;

  PUnitName = ^TUnitName;
  TUnitName = packed record
    Flags : Byte;
    HashCode: Byte;
    Name: array[0..255] of Char;
  end;

  PPackageInfoHeader = ^TPackageInfoHeader;
  TPackageInfoHeader = packed record
    Flags: Cardinal;
    RequiresCount: Integer;
    {Requires: array[0..9999] of TPkgName;
    ContainsCount: Integer;
    Contains: array[0..9999] of TUnitName;}
  end;

  TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
  TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;

const
  STypeInfoPrefix = '@$xp$';

var
  EnumModules: TEnumModulesProc = nil;

function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;

function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
  InfoTable: Pointer;
begin
  Result := False;

  if (Module <> HInstance) then
  begin
    InfoTable := PackageInfoTable(Module);
    if Assigned(InfoTable) then
      TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
  end;
end;

function GetPackageDescription(Module: HMODULE): string;
var
  ResInfo: HRSRC;
  ResData: HGLOBAL;
begin
  Result := '';
  ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
  if ResInfo <> 0 then
  begin
    ResData := LoadResource(Module, ResInfo);
    if ResData <> 0 then
    try
      Result := PWideChar(LockResource(ResData));
      UnlockResource(ResData);
    finally
      FreeResource(ResData);
    end;
  end;
end;

function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
  ProcessHandle: THandle;
  SizeNeeded: Cardinal;
  P, ModuleHandle: PDWORD;
  I: Integer;
begin
  Result := False;

  ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
  if ProcessHandle = 0 then
    RaiseLastOSError;
  try
    SizeNeeded := 0;
    EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
    if SizeNeeded = 0 then
      Exit;

    P := AllocMem(SizeNeeded);
    try
      if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
      begin
        ModuleHandle := P;
        for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
        begin
          if Callback(ModuleHandle^, Data) then
            Exit;
          Inc(ModuleHandle);
        end;

        Result := True;
      end;
    finally
      FreeMem(P);
    end;
  finally
    CloseHandle(ProcessHandle);
  end;
end;

function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
  Result := False;
  // todo win9x?
end;

function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
  ResInfo: HRSRC;
  Data: THandle;
begin
  Result := nil;
  ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
  if ResInfo <> 0 then
  begin
    Data := LoadResource(Module, ResInfo);
    if Data <> 0 then
    try
      Result := LockResource(Data);
      UnlockResource(Data);
    finally
      FreeResource(Data);
    end;
  end;
end;

{ TDelphiProcess private }

function TDelphiProcess.GetPackageCount: Integer;
begin
  Result := FPackages.Count;
end;

function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
  Result := FPackages[Index];
end;

{ TDelphiProcess public }

constructor TDelphiProcess.Create;
begin
  inherited Create;
  FPackages := TDelphiPackageList.Create;
  Reload;
end;

destructor TDelphiProcess.Destroy;
begin
  FPackages.Free;
  inherited Destroy;
end;

procedure TDelphiProcess.Clear;
begin
  FPackages.Clear;
end;

function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
  I: Integer;
begin
  Result := nil;

  for I := 0 to FPackages.Count - 1 do
    if FPackages[I].Handle = Handle then
    begin
      Result := FPackages[I];
      Break;
    end;
end;

procedure TDelphiProcess.Reload;
begin
  Clear;

  if Assigned(EnumModules) then
    EnumModules(AddPackage, FPackages);
end;

{ TDelphiPackageList protected }

function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
  Result := TDelphiPackage(inherited GetItem(Index));
end;

procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
  inherited SetItem(Index, APackage);
end;

{ TDelphiPackageList public }

function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
  Result := inherited Add(APackage);
end;

function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
  Result := TDelphiPackage(inherited Extract(APackage));
end;

function TDelphiPackageList.First: TDelphiPackage;
begin
  Result := TDelphiPackage(inherited First);
end;

function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
  Result := inherited IndexOf(APackage);
end;

procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
  inherited Insert(Index, APackage);
end;

function TDelphiPackageList.Last: TDelphiPackage;
begin
  Result := TDelphiPackage(inherited Last);
end;

function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
  Result := inherited Remove(APackage);
end;

{ TDelphiPackage private }

procedure TDelphiPackage.CheckInfoTable;
begin
  if not Assigned(FInfoTable) then
    FInfoTable := PackageInfoTable(Handle);

  if not Assigned(FInfoTable) then
    raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;

procedure TDelphiPackage.CheckTypeInfos;
var
  ExportDir: PImageExportDirectory;
  Size: DWORD;
  Names: PDWORD;
  I: Integer;
begin
  if not Assigned(FTypeInfos) then
  begin
    FTypeInfos := TList.Create;
    try
      Size := 0;
      ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
      if not Assigned(ExportDir) then
        Exit;

      Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
      for I := 0 to ExportDir^.NumberOfNames - 1 do
      begin
        if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
          Break;
        FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
        Inc(Names);
      end;
    except
      FreeAndNil(FTypeInfos);
      raise;
    end;
  end;
end;

function TDelphiPackage.GetDescription: string;
begin
  Result := GetPackageDescription(Handle);
end;

function TDelphiPackage.GetFileName: string;
begin
  Result := GetModuleName(FHandle);
end;

function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
  P: Pointer;
  Count: Integer;
  I: Integer;
begin
  Result := '';
  CheckInfoTable;
  Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
  P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
  case NameType of
    ntContainsUnit:
      begin
        for I := 0 to Count - 1 do
          P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
        Count := Integer(P^);
        P := Pointer(Cardinal(P) + SizeOf(Integer));
        if (Index >= 0) and (Index < Count) then
        begin
          for I := 0 to Count - 1 do
            P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
          Result := PUnitName(P)^.Name;
        end;
      end;
    ntRequiresPackage:
      if (Index >= 0) and (Index < Count) then
      begin
        for I := 0 to Index - 1 do
          P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
        Result := PPkgName(P)^.Name;
      end;
    ntDcpBpiName:
      if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
      begin
        for I := 0 to Count - 1 do
          P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
        Count := Integer(P^);
        P := Pointer(Cardinal(P) + SizeOf(Integer));
        for I := 0 to Count - 1 do
          P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
        Result := PPkgName(P)^.Name;
      end;
  end;
end;

function TDelphiPackage.GetShortName: string;
begin
  Result := GetInfoName(ntDcpBpiName, 0);
end;

function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
  I: Integer;
begin
  CheckTypeInfos;
  Result := 0;
  for I := 0 to FTypeInfos.Count - 1 do
    if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
      Inc(Result);
end;

function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
  I, J: Integer;
begin
  CheckTypeInfos;
  Result := nil;
  J := -1;
  for I := 0 to FTypeInfos.Count - 1 do
    if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
    begin
      Inc(J);
      if J = Index then
      begin
        Result := FTypeInfos[I];
        Break;
      end;
    end;
end;

{ TDelphiPackage public }

constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
  inherited Create;
  FHandle := AHandle;
  FInfoTable := AInfoTable;
  FTypeInfos := nil;
end;

destructor TDelphiPackage.Destroy;
begin
  FTypeInfos.Free;
  inherited Destroy;
end;

initialization
  case Win32Platform of
    VER_PLATFORM_WIN32_WINDOWS:
      EnumModules := EnumModulesTH;
    VER_PLATFORM_WIN32_NT:
      EnumModules := EnumModulesPS;
    else
      EnumModules := nil;
  end;

finalization

end.

IDE中安装的测试设计包的单元：

unit Test;

interface

uses
  SysUtils, Classes,
  ToolsAPI;

type
  TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
  private
    { IOTAWizard }
    procedure Execute;
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    { IOTAMenuWizard }
    function GetMenuText: string;
  end;

implementation

uses
  TypInfo,
  PackageUtils;

function AncestryStr(AClass: TClass): string;
begin
  Result := '';
  if not Assigned(AClass) then
    Exit;

  Result := AncestryStr(AClass.ClassParent);
  if Result <> '' then
    Result := Result + '\';
  Result := Result + AClass.ClassName;
end;

procedure ShowMessage(const S: string);
begin
  with BorlandIDEServices as IOTAMessageServices do
    AddTitleMessage(S);
end;

{ TTestWizard }

procedure TTestWizard.Execute;
var
  Process: TDelphiProcess;
  I, J: Integer;
  Package: TDelphiPackage;
  PInfo: PTypeInfo;
  PData: PTypeData;

begin
  Process := TDelphiProcess.Create;
  for I := 0 to Process.PackageCount - 1 do
  begin
    Package := Process.Packages[I];
    for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
    begin
      PInfo := Package.TypeInfos[[tkClass], J];
      PData := GetTypeData(PInfo);
      ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
    end;
  end;
end;

function TTestWizard.GetIDString: string;
begin
  Result := 'TOndrej.TestWizard';
end;

function TTestWizard.GetName: string;
begin
  Result := 'Test';
end;

function TTestWizard.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

function TTestWizard.GetMenuText: string;
begin
  Result := 'Test';
end;

var
  Index: Integer = -1;

initialization
  with BorlandIDEServices as IOTAWizardServices do
    Index := AddWizard(TTestWizard.Create);

finalization
  if Index <> -1 then
    with BorlandIDEServices as IOTAWizardServices do
      RemoveWizard(Index);

end.

您必须将 designide 添加到您的 requires 子句中。当你安装这个设计包时，一个新的菜单项 Test 应该出现在 Delphi 的 Help 菜单下。单击它应该会在消息窗口中显示所有加载的类。

于 2009-04-19T08:33:30.193 回答
1

你试过Delphi自带的类浏览器吗？

浏览器使用快捷键 CTRL-SHIFT-B 加载。我相信您可以通过在浏览器中单击鼠标右键来访问其选项。在这里，您可以选择仅显示项目中的类或所有已知类。

我还没有检查，但我希望 TComponent 的每个后代，包括已安装的组件都在 TComponent 节点下方可见。使用 CTRL-F 搜索特定类。

编辑：根据这个Delphi Wiki page，CTRL+SHIFT+B 仅在 Delphi5 中可用。我没有 Delphi 2007 来检查这个，但如果你在你的版本中找不到类浏览器，我怀疑没有。

于 2009-04-18T12:19:55.027 回答