TClass-Objkete einer Anwendung auflisten

[himitsu]

Theoretisch ist es möglich, aber es können/werden wohl auch viele falsche Funde auftauchen.

Im Prinzip mußt du nur nach Strukturen suchen, welche "typische" für eine Klasse sind.


[add]

Delphi-Quellcode:

Function MyIsClass(C: TClass; MaxRecursion: Integer = 32): Boolean;
  Var B: Boolean;
    i, i2: Integer;
    PropList: PPropList;
    S: PShortString;
    C2: TClass;

  Label None;

  Begin
    Result := False;
    Try
      If (C = nil) or (Integer(C) and $3 <> 0) Then Goto None;
      {***** vmtSelfPtr *****}
      //If PInteger(C + vmtSelfPtr)^ = C Then Goto None;
      {***** vmtTypeInfo *****}
      //If C.ClassInfo <> nil Then Begin
      //  i := GetPropList(PTypeInfo(C.ClassInfo), PropList);
      //  B := False;
      //  If i > 0 Then
      //    Try
      //      For i := i - 1 downto 0 do
      //        For i2 := 1 to Length(PropList[i].Name) do
      //          If not (PropList[i].Name[i2] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) Then B := True;
      //    Finally
      //      FreeMem(PropList);
      //    End;
      //  If B Then Goto None;
      //End;
      {***** vmtClassName *****}
      S := PShortString(PPointer(Integer(C) + vmtClassName)^);
      If Length(S^) < 1 Then Goto None;
      For i2 := 1 to Length(S^) do
        If not (S^[i2] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) Then Goto None;
      {***** vmtInstanceSize *****}
      If (TClass(C).InstanceSize < 0) or (TClass(C).InstanceSize > 1048576) Then Goto None;
      {***** vmtParent *****}
      If MaxRecursion = 0 Then Goto None;
      S := PShortString(PPointer(Integer(C) + vmtClassName)^);
      Result := (S^{C.ClassName} = 'TObject') or MyIsClass(TClass(C).ClassParent, MaxRecursion - 1);
      None:
    Except
    End;
  End;

Procedure TForm2.Button1Click(Sender: TObject);
  Var C: Integer;
    MBI: MEMORY_BASIC_INFORMATION;
    i: Integer;

  Begin
    Button1.Hide;
    // HInstance entspricht der Startspeicheradresse der EXE im RAM

    // der erste Speicherblock ist irgendwas Anderes
    // (eventuell enthält er die API-Funktionszeiger und globalen Variablen? )
    VirtualQuery(Pointer(HInstance), MBI, SizeOf(MBI));

    // der zweite Speicherblock dürfte die Codesection sein
    VirtualQuery(Pointer(Integer(MBI.BaseAddress) + MBI.RegionSize), MBI, SizeOf(MBI));

    For C := Integer(MBI.BaseAddress) - vmtSelfPtr to Integer(MBI.BaseAddress) + MBI.RegionSize - SizeOf(TClass) do Begin
      If MyIsClass(TClass(C)) Then Memo1.Lines.Add(Format('$%.8d %s', [C, TClass(C).ClassName]));
      If C and $FF = 0 Then Begin
        Caption := IntToStr(Integer(MBI.BaseAddress) + MBI.RegionSize - SizeOf(TClass) - C);
        Application.ProcessMessages;
      End;
    End;
    Caption := 'fertig';
  End;

Benötigt werden für den Test ein TMemo (Memo1) und ein TButton (Button1)

Aber wie schon gesagt, 100% zuverlässig und vorallem schnell ist es nicht gerade.