program Project1;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  windows, System.SysUtils, System.Generics.Collections;

function GetObjectClass(APointer: Pointer): TClass;
{$IFDEF MSWINDOWS}
var
  LMemInfo: TMemoryBasicInformation;

  { Checks whether the given address is a valid address for a VMT entry. }
  function IsValidVMTAddress(APAddress: Pointer): Boolean;
  begin
    { Do some basic pointer checks: Must be dword aligned and beyond 64K }
    if (UIntPtr(APAddress) > 65535) and (UIntPtr(APAddress) and 3 = 0) then
    begin
      { Do we need to recheck the virtual memory? }
      if (UIntPtr(LMemInfo.BaseAddress) > UIntPtr(APAddress)) or
        ((UIntPtr(LMemInfo.BaseAddress) + NativeUInt(LMemInfo.RegionSize)) <
        (UIntPtr(APAddress) + SizeOf(Pointer))) then
      begin
        { Get the VM status for the pointer }
        LMemInfo.RegionSize := 0;
        VirtualQuery(APAddress, LMemInfo, SizeOf(LMemInfo));
      end;
      { Check the readability of the memory address }
      Result := (NativeUInt(LMemInfo.RegionSize) >= SizeOf(Pointer)) and
        (LMemInfo.State = MEM_COMMIT) and
        (LMemInfo.Protect and (PAGE_READONLY or PAGE_READWRITE or
        PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or
        PAGE_EXECUTE_WRITECOPY) <> 0) and (LMemInfo.Protect and PAGE_GUARD = 0);
    end
    else
      Result := False;
  end;

{ Returns true if AClassPointer points to a class VMT }
  function InternalIsValidClass(AClassPointer: Pointer;
    ADepth: Integer = 0): Boolean;
  var
    LParentClassSelfPointer: PPointer;
  begin
    { Check that the self pointer as well as parent class self pointer addresses
      are valid }
    if (ADepth < 1000) and IsValidVMTAddress
      (Pointer(PByte(AClassPointer) + vmtSelfPtr)) and
      IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtParent)) then
    begin
      { Get a pointer to the parent class' self pointer }
      LParentClassSelfPointer := PPointer(PByte(AClassPointer) + vmtParent)^;
      { Check that the self pointer as well as the parent class is valid }
      Result := (PPointer(PByte(AClassPointer) + vmtSelfPtr)^ = AClassPointer)
        and ((LParentClassSelfPointer = nil) or
        (IsValidVMTAddress(LParentClassSelfPointer) and
        InternalIsValidClass(LParentClassSelfPointer^, ADepth + 1)));
    end
    else
      Result := False;
  end;

begin
  { Get the class pointer from the (suspected) object }
  Result := TClass(PNativeUInt(APointer)^);
  { No VM info yet }
  LMemInfo.RegionSize := 0;
  { Check the block }
  if not InternalIsValidClass(Pointer(Result), 0) then
    Result := nil;
{$ELSE !MSWINDOWS}
begin
  { Not currently supported under Linux / OS X }
  Result := nil;
{$ENDIF MSWINDOWS}
end;

procedure Test(IsCreate: Boolean);
type
  sc = TDictionary<String, String>;
var
  list: sc;
  c: TClass;
begin
  if IsCreate then
    list := sc.Create;

  c := GetObjectClass(list);
  if c <> nil then
  begin
    Writeln('Объект есть: ' + c.ClassName);
    list.Clear;
    list.Destroy;
  end
  else
    Writeln('Объект нет');
end;

var
  i: Char;

begin
  try
    repeat
      Writeln('Создать объект? Y\N\Q');
      Readln(i);

      Test((i = 'Y') or (i = 'y'));
    until (i = 'Q') or (i = 'q');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

end.