Comment "scanner" la liste complète des composants VCL actuellement installés

Question

Je n'ai toujours pas trouvé de réponse vraiment satisfaisante à this question, et je suis en train d'envisager de lancer la mienne. J'ai ModelMaker et GExperts, et aucun ne semble charger le complet classe-hiérarchie que je cherche. De plus, je ne pense pas que les gens de DevExpress vont bifurquer sur le code CDK qui compile une liste de classe complète pour hériter de ... ;-)

SO ...

Si ALL I vouloir faire est de construire une table d'auto-référencement de toutes les classes de composants enregistrés (ou même toutes les classes, y compris les non-composants, si c'est aussi facile/possible), quelle serait la meilleure façon de faire cela?

Remarque: Je n'ai pas vraiment besoin de détails sur les propriétés/méthodes; JUSTE une liste complète des noms de classe (et les noms des parents) je peux stocker à une table et mettre dans une arborescence. Quoi que ce soit au-delà de cela, cependant, est plus que bienvenue en tant qu'information de bonus. :-)

---

mise à jour plus tard:

Une réponse qui apparaît dans ma section "récente" sur le SO, mais pas ici sur la question (? Peut-être qu'ils effaçait), était le suivant:

"Vous pouvez jeter un oeil sur le code de recherche de composants, il peut vous aider à énumérer tous les composants installés."

Ce code est-il disponible? Est-ce le cas, où se cache-t-il? Serait intéressant d'étudier.

Answer 1

Une autre idée consiste à rechercher des informations de type qui se trouvent au-dessus de la liste des fonctions exportées, de sorte que vous pouvez ignorer l'énumération. Les informations de type sont exportées avec des noms commençant par le préfixe '@ $ xp $'. Voici un exemple:

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. 

Unité du package de conception de test installé dans l'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. 

Vous devez ajouter à votre DesignIDE exige l'article. Lorsque vous installez ce package de conception, un nouvel élément de menu Test doit apparaître sous le menu Aide de Delphi. En cliquant dessus, il devrait afficher toutes les classes chargées dans la fenêtre Messages.

Answer 2

Avez-vous essayé le propre navigateur de classe de Delphi?

Le navigateur est chargé avec le raccourci CTRL-SHIFT-B. Je crois que vous pouvez accéder à ses options en cliquant droit dans le navigateur. Ici, vous avez la possibilité d'afficher uniquement les classes de votre projet ou toutes les classes connues.

Je n'ai pas vérifié mais j'attends tout descendant de TComponent, y compris les composants installés visibles en dessous du noeud TComponent. Utilisez CTRL-F pour rechercher une classe particulière.

---

Edit: selon cette page Delphi Wiki, CTRL + MAJ + B est seulement disponible en Delphi5. Je n'ai pas Delphi 2007 pour vérifier cela, mais si vous ne trouvez pas un navigateur de classe dans votre version, je suppose qu'il n'y en a pas.

Answer 3

Malheureusement, le code implémentant le mécanisme RegisterClass est masqué dans la section Implémentation des classes.

Si vous en avez besoin pour obtenir la liste des composants installés dans l'EDI, vous pouvez écrire un package de conception, l'installer dans l'EDI et utiliser IOTAPackageServices dans l'unité ToolsAPI. Cela vous donnera la liste des paquets installés et de leurs composants.

Remarque: Vous devrez ajouter designide.dcp à votre clause 'requires' pour pouvoir utiliser les unités internes de Delphi comme ToolsAPI.

Un peu plus de travail mais un moyen plus générique serait d'énumérer tous les modules chargés. Vous pouvez appeler GetPackageInfo (SysUtils) sur un module de package pour énumérer les noms d'unités contenues et les packages requis. Cependant, cela ne vous donnera pas une liste des classes contenues dans le paquet.

Vous pouvez énumérer la liste des fonctions exportées (avec TJclPeImage dans le JCL) et la recherche de ceux qui sont nommés comme celui-ci du package:

@<unit_name>@<class_name>@

par exemple: « @ System @ TObject @ '.

En appelant GetProcAddress avec le nom de la fonction, vous obtenez la référence TClass. De là, vous pouvez parcourir la hiérarchie en utilisant ClassParent. De cette façon, vous pouvez énumérer toutes les classes dans tous les paquets chargés dans un processus exécutant un exécutable Delphi compilé avec des paquets d'exécution (Delphi IDE, aussi).