How to “scan” the full list of currently-installed VCL components

Question

I still haven\'t found a truly satisfactory answer to this question, and am now considering rolling my own. I have ModelMaker and GExperts, and neither seems to load the co

Answer 1

Have you tried Delphi's own class browser?

The browser gets loaded with shortcut CTRL-SHIFT-B. I believe you can access its options by right clicking in the browser. Here you have the option to show only the classes in your project or all known classes.

I haven't checked but I expect every descendant from TComponent, including installed components to be visible below the TComponent node. Use CTRL-F to search for a particular class.

---

Edit: according to this Delphi Wiki page, CTRL+SHIFT+B is only available in Delphi5. I don't have Delphi 2007 to check for this but if you can not find a class browser in your version, I'd suspect there isn't any.

Answer 2

Another idea is to scan for type information which is on top of the list of exported functions so you can skip enumerating further. The type infos are exported with names starting with prefix '@$xp$'. Here's an example:

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 of the test design package installed in the 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.

You have to add designide to your requires clause. When you install this design package a new menu item Test should appear under Delphi's Help menu. Clicking it should display all loaded classes in the Messages window.

Answer 3

Unfortunately, the code implementing the RegisterClass mechanism is hidden in Classes implementation section.

If you need this for getting the list of components installed in the IDE, you can write a design package, install it into the IDE and use IOTAPackageServices in ToolsAPI unit. This will give you the list of installed packages and their components.

Note: You'll have to add designide.dcp to your 'requires' clause to be able to use Delphi's internal units like ToolsAPI.

A bit more work but a more generic way would be to enumerate all loaded modules. You can call GetPackageInfo (SysUtils) on a package module to enumerate contained unit names and required packages. However this will not give you a list of classes contained in the package.

You could enumerate the package's list of exported functions (e.g. with TJclPeImage in the JCL) and search for those named like this:

@<unit_name>@<class_name>@

for example: '@System@TObject@'.

By calling GetProcAddress with the function name you get the TClass reference. From there you can walk the hierarchy using ClassParent. This way you can enumerate all classes in all packages loaded in a process running a Delphi executable compiled with runtime packages (Delphi IDE, too).