如何「掃描」當前安裝的VCL組件的完整列表

Question

我還沒有找到this question真正滿意的答案，現在我正在考慮自己開發。我有ModelMaker和GExperts，並且都沒有加載我期待的類層次結構綜合。同時，我不認爲在DevExpress的鄉親將叉在其編譯一個滿級列表，從繼承CDK代碼... ;-)

SO ...

如果ALL我想要做的是構建一個所有註冊組件類的自引用表（甚至包括所有類，包括非組件，如果這很容易/可能），那麼最好的方法是什麼？

注：我並不真的需要屬性/方法的細節;只是一個完整的類名（和父名）的列表，我可以存儲到一個表中，並放在樹視圖中。除此之外的任何事情都是值得歡迎的，因爲它們是額外的信息。 :-)

---

更新後：

一個答案，在我的「最近」部分SO，而不是在這裏顯示出來的問號（？也許他們將其擦除），是這樣的：

「你可能想看看組件搜索的代碼，它可以幫助你枚舉安裝的所有組件。」

該代碼是否可用？是的，它隱藏在哪裏？研究會很有趣。

Answer 1

另一個想法是掃描位於導出函數列表頂部的類型信息，以便您可以跳過進一步的枚舉。類型信息導出的名稱以前綴'@ $ 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添加到您的要求條款。當你安裝這個設計包時，Delphi的幫助菜單下會出現一個新的菜單項Test。點擊它應該在消息窗口中顯示所有加載的類。

Answer 2

你有沒有試過Delphi自己的類瀏覽器？

瀏覽器使用快捷鍵CTRL-SHIFT-B加載。我相信你可以通過在瀏覽器中點擊右鍵來訪問它的選項。在這裏，您可以選擇僅顯示項目中的類或所有已知類。

我沒有檢查過，但我期望TComponent的每個後代，包括已安裝的組件在TComponent節點下方都可見。使用CTRL-F搜索特定的類。

---

編輯：根據本Delphi Wiki頁，CTRL + SHIFT + B只在Delphi5可用。我沒有德爾福2007年檢查這個，但如果你不能在你的版本中找到類瀏覽器，我會懷疑沒有。

Answer 3

不幸的是，實現RegisterClass機制的代碼隱藏在類實現部分。

如果您需要獲取安裝在IDE中的組件列表，可以編寫一個設計包，將其安裝到IDE中並使用ToolsAPI單元中的IOTAPackageServices。這會給你已安裝的軟件包及其組件的列表。

注意：您必須將designide.dcp添加到'requires'子句才能使用Delphi的內部單元（如ToolsAPI）。

多一點工作，但更通用的方式是枚舉所有加載的模塊。您可以調用封裝模塊上的GetPackageInfo（SysUtils）來枚舉包含的單元名稱和所需的軟件包。但是這不會給你一個包中包含的類的列表。

你可以（在JCL與TJclPeImage例如）枚舉的導出函數的程序包的列表和搜索這些命名是這樣的：

@<unit_name>@<class_name>@

例如：「@系統@ TObject的@」。

通過使用函數名稱調用GetProcAddress，您將獲得TClass引用。從那裏你可以使用ClassParent來遍歷層次結構。通過這種方式，您可以枚舉運行使用運行時包編譯的Delphi可執行文件的進程中加載​​的所有包中的所有類（Delphi IDE）。