5

私はまだこの質問に対する本当に満足のいく答えを見つけていません、そして今私自身を転がすことを考えています。私はModelMakerとGExpertsを持っていますが、どちらも私が探している包括的なクラス階層をロードしていないようです。同様に、DevExpressの人々は、継承するために完全なクラスリストをコンパイルするCDKコードをフォークすることはないと思います...;-)

それで...

登録されているすべてのコンポーネントクラス（または、同じように簡単/可能であれば、非コンポーネントを含むすべてのクラス）の自己参照テーブルを作成するだけの場合、それを実行するための最良の方法は何でしょうか。

注：プロパティ/メソッドの詳細は実際には必要ありません。クラス名（および親名）の完全なリストをテーブルに保存してツリービューに配置できます。それ以上のものは、ボーナス情報として大歓迎です。:-)

後で更新：

SOの「最近の」セクションに表示されますが、ここでは質問に表示されない1つの答え（おそらく彼らはそれを消去しましたか？）は、次のとおりです

。インストールされているすべてのコンポーネントを列挙します。」

そのコードは利用できますか？そうですか、どこに隠れていますか？勉強するのも面白いでしょう。

4

3 に答える 3

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.

requires句にdesignideを追加する必要があります。このデザイン パッケージをインストールすると、Delphi の [ヘルプ] メニューの下に新しいメニュー項目 [テスト] が表示されます。クリックすると、読み込まれたすべてのクラスが [メッセージ] ウィンドウに表示されます。

于 2009-04-19T08:33:30.193 に答える
1

Delphi独自のクラスブラウザを試しましたか？

ブラウザにショートカットCTRL-SHIFT-Bが読み込まれます。ブラウザを右クリックすると、そのオプションにアクセスできると思います。ここでは、プロジェクト内のクラスのみ、またはすべての既知のクラスを表示するオプションがあります。

確認していませんが、インストールされているコンポーネントを含め、TComponentのすべての子孫がTComponentノードの下に表示されることを期待しています。Ctrl-Fを使用して、特定のクラスを検索します。

編集：このDelphi Wikiページによると、CTRL + SHIFT+BはDelphi5でのみ使用できます。これをチェックするDelphi2007はありませんが、ご使用のバージョンでクラスブラウザーが見つからない場合は、何もないと思われます。

于 2009-04-18T12:19:55.027 に答える