delphi проверить является ли pointer Tobject

Давно мучает вопрос как верно проверить является ли pointer Tobject написал как смог но реализация мне не нравится. какие есть способы?

function CheckObject(aPointer:Pointer):boolean;
var Ob:TObject;
s:string;
//i:integer;
begin
 Result:=false;
 try
  if Assigned(aPointer)then
  begin
    Ob:= TObject(aPointer);
    if  Assigned(Ob)    then
    begin
     //i:=sizeof(Ob);
     s:=Ob.ToString;
     Result:=(Ob is TObject);
    end;
  end;
 except
   Result:=false;
 end;

end;

Покапал интернет нашел пару функций по этой теме все запихнул в модуль

unit AmSystemBase;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes;

 type
  AmSys =  class


     class function PoiterIsObject(P:Pointer;
                                  IsLongCheck:boolean=false;
                                  LMemInfo: PMemoryBasicInformation=nil;
                                  SysInfo:PSystemInfo=nil):boolean;


     class function GetObjectClass(APointer: Pointer;
                                   IsLongCheck:boolean=false;
                                   LMemInfo: PMemoryBasicInformation=nil;
                                   SysInfo:PSystemInfo=nil): TClass;

     class function IsValidVMTAddress(APAddress: PCardinal;LMemInfo: PMemoryBasicInformation): Boolean;

     class function InternalIsValidClass(AClassPointer: Pointer;
                                         ADepth: Integer=0;
                                         IsLongCheck:boolean=false;
                                         LMemInfo: PMemoryBasicInformation=nil
                                         ): Boolean;


  end;

  TAmSysObjectCheck = class
    protected
      MemInfo: TMemoryBasicInformation;
      SysInfo:TSystemInfo;
    public
      IsLongCheck:boolean;
      function PoiterIsObject(APointer:Pointer):boolean;
      function GetPointerClass(APointer: Pointer):TClass;
      constructor Create;
  end;

implementation


{ AmSys }

class function AmSys.PoiterIsObject(P: Pointer;
                                    IsLongCheck: boolean=false;
                                    LMemInfo: PMemoryBasicInformation=nil;
                                    SysInfo:PSystemInfo=nil): boolean;
begin
    Result := GetObjectClass(P,IsLongCheck,LMemInfo,SysInfo)<>nil;
end;

class function AmSys.GetObjectClass(APointer: Pointer;
                                    IsLongCheck: boolean=false;
                                    LMemInfo: PMemoryBasicInformation=nil;
                                    SysInfo:PSystemInfo=nil): TClass;
var
  LSystemInfo: TSystemInfo;
begin
   if SysInfo=nil then
   begin
    FillChar(LSystemInfo,sizeof(LSystemInfo),0);
    SysInfo:=@LSystemInfo;
   end;
   if (SysInfo.lpMinimumApplicationAddress = nil) and
   (SysInfo.lpMaximumApplicationAddress = nil) then
   begin
    GetSystemInfo(LSystemInfo);
    if SysInfo <>@LSystemInfo then
    SysInfo^:= LSystemInfo;
   end;


  if (DWORD(APointer) <= DWORD(SysInfo.lpMinimumApplicationAddress)) or
    (DWORD(APointer) >= DWORD(SysInfo.lpMaximumApplicationAddress)) or
    IsBadReadPtr(APointer, 4) then
  begin
    Result := nil;
    Exit;
  end;
  Result := TClass(PCardinal(APointer)^);
  if not InternalIsValidClass(Pointer(Result), 0,IsLongCheck,LMemInfo) then
    Result := nil;
end;

class function AmSys.InternalIsValidClass(AClassPointer: Pointer;
                                          ADepth: Integer=0;
                                          IsLongCheck:boolean=false;
                                          LMemInfo: PMemoryBasicInformation=nil): Boolean;
  var
    LParentClassSelfPointer: PCardinal;
   // C,C2:TClass;
   LMem: TMemoryBasicInformation;
begin
    if LMemInfo=nil then
    begin
     FillChar(LMem,sizeof(LMem),0);
     LMemInfo:=@LMem;
    end;

    {Check that the self pointer as well as parent class self pointer addresses
     are valid}
    if (ADepth < 1000)
      and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtSelfPtr),LMemInfo)
      and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtParent),LMemInfo) then
    begin
      {Get a pointer to the parent class' self pointer}
      LParentClassSelfPointer := PPointer(Integer(AClassPointer) + vmtParent)^;
     // C:=TClass(Integer(AClassPointer));
     // C2:=TClass(PCardinal(LParentClassSelfPointer)^);

      {Check that the self pointer as well as the parent class is valid}
      Result := (PPointer(Integer(AClassPointer) + vmtSelfPtr)^ = AClassPointer);

      if not IsLongCheck then
      begin
       Result:= Result
        and ( (LParentClassSelfPointer = nil) or (IsValidVMTAddress(LParentClassSelfPointer,LMemInfo)) );
      end
      else
      begin
       Result:= Result
        and (
              (LParentClassSelfPointer = nil)
              or (IsValidVMTAddress(LParentClassSelfPointer,LMemInfo)
              and InternalIsValidClass(PCardinal(LParentClassSelfPointer^), ADepth + 1))
          );
      end;

    end
    else
      Result := False;
end;


class function AmSys.IsValidVMTAddress(APAddress: PCardinal;LMemInfo: PMemoryBasicInformation): Boolean;
var LMem: TMemoryBasicInformation;
begin
  {Do some basic pointer checks: Must be dword aligned and beyond 64K}
  if (Cardinal(APAddress) > 65535)
    and (Cardinal(APAddress) and 3 = 0) then
  begin


    if LMemInfo=nil then
    begin
     FillChar(LMem,sizeof(LMem),0);
     LMemInfo:=@LMem;
    end;


    {Do we need to recheck the virtual memory?}
    if (Cardinal(LMemInfo.BaseAddress) > Cardinal(APAddress))
      or ((Cardinal(LMemInfo.BaseAddress) + Cardinal(LMemInfo.RegionSize)) < (Cardinal(APAddress) + 4)) then
    begin
      {Get the VM status for the pointer}
      FillChar(LMem,sizeof(LMem),0);
      LMem.RegionSize := 0;
      VirtualQuery(APAddress,  LMem, SizeOf(LMem));
      if LMemInfo <>@LMem then
      LMemInfo^:=LMem;
    end;
    {Check the readability of the memory address}
    Result := (Cardinal(LMemInfo.RegionSize) >= 4)
      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;




{ TAmSysObjectCheck }

constructor TAmSysObjectCheck.Create;
begin
 inherited ;
 IsLongCheck:=false;
 FillChar(MemInfo,sizeof(MemInfo),0);
 FillChar(SysInfo,sizeof(SysInfo),0);
end;

function TAmSysObjectCheck.GetPointerClass(APointer: Pointer): TClass;
begin
    Result:= AmSys.GetObjectClass(APointer,IsLongCheck,@MemInfo,@SysInfo);
end;

function TAmSysObjectCheck.PoiterIsObject(APointer: Pointer): boolean;
begin
   Result:= AmSys.PoiterIsObject(APointer,IsLongCheck,@MemInfo,@SysInfo);
end;

end.

Использую так

procedure TAmEventStrings.SfInternalClear;
var i:integer;
ObjCheck:TAmSysObjectCheck;//<< ВОТ ОБЪЕКТ КОТОРЫЙ ЧЕКАЕТ POINTER
begin
  if not Assigned(Sf) or (Sf.Count<=0) then  exit;

  ObjCheck:=TAmSysObjectCheck.Create;
  try
    for I := Sf.Count-1 downto 0 do
    SfInternalFreeObject(I,ObjCheck);
  finally
     FreeAndNil(ObjCheck);
     Sf.Clear;
  end;



end;

procedure TAmEventStrings.SfInternalFreeObject(Index: integer;ObjCheck:TAmSysObjectCheck);
var I:integer;
 ObjCheckCreate:boolean;
 P:Pointer;
begin
    P:= Sf[Index];
    if not Assigned(P) then
    exit;

    if not Assigned(ObjCheck) then
    begin
      ObjCheckCreate:=true;
      ObjCheck:=TAmSysObjectCheck.Create;
    end
    else ObjCheckCreate:=false;
    try

      for I := 0 to FListObjectItemClass.Count-1 do
        if Assigned(FListObjectItemClass[i])  then
        begin
         if ObjCheck.PoiterIsObject(P) and   ( TObject(P) is FListObjectItemClass[i]) then
         begin
          Sf[Index]:=nil;
          TObject(P).Free;
          //P:=nil;
          exit;
         end;
        end;
    finally
        if ObjCheckCreate then
        FreeAndNil(ObjCheck);
    end;

end;