如何"扫描"当前安装的VCL组件的完整列表

Question

如何"扫描"当前安装的VCL组件的完整列表

Jam*_*amo 5 ide delphi components vcl class

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

所以...

如果所有我想要做的是建立所有已注册的组件类的自引用表(甚至所有类别,包括非组件,如果这是一样容易/可能),这将是去这样做,最好的方法是什么？

注意:我真的不需要属性/方法细节; 只是一个完整的类名(和父名)列表,我可以存储到表中并放入树视图.不过,除此之外的任何事情都非常受欢迎,作为奖励信息.:-)

稍后更新:

一个答案显示在我的"最近"部分关于SO,但问题不在这里(可能是它们删除了吗？),是这样的:

"你可能想看看组件搜索的代码,它可能会帮助你枚举安装的所有组件."

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

Answer 1

Ond*_*lle 5

不幸的是,实现RegisterClass机制的代码隐藏在Classes实现部分中.

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

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

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

您可以枚举包的导出函数列表(例如,在JCL中使用TJclPeImage )并搜索以下命名的那些:

@<unit_name>@<class_name>@

例如:'@ System @ TObject @'.

通过使用函数名称调用GetProcAddress,您将获得TClass引用.从那里,您可以使用ClassParent遍历层次结构.这样,您可以枚举在运行使用运行时包(Delphi IDE)编译的Delphi可执行文件的进程中加载的所有包中的所有类.

Answer 2

Ond*_*lle 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.

Run Code Online (Sandbox Code Playgroud)

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.

Run Code Online (Sandbox Code Playgroud)

您必须将 designide 添加到您的 require 子句中。当您安装此设计包时，Delphi 的“帮助”菜单下应出现一个新的菜单项“测试”。单击它应该会在消息窗口中显示所有加载的类。

归档时间：	16 年，4 月前
查看次数：	1914 次
最近记录：	13 年，5 月前