[infopol]

Может кто подскажет,как получить GUID Ole object

Код:

unit OleObject;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs,ActiveX,ComObj,Ole2,OleAuto, Vcl.StdCtrls,
  Vcl.OleCtrls,OleConst,OleCtl,
      TypInfo,

{$IFDEF INTF_TYPEINFO_CACHE}
  System.Generics.Collections,
{$ENDIF}Rtti;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    ComboBox1: TComboBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
 function VariantObjectClassName(const V: OleVariant): string;
 function GetImplementingObject(const I: IInterface): TObject;
  function GetInterfaceEntry(const I: IInterface): PInterfaceEntry;
 function GetPIMTOffset(const I: IInterface): integer;
implementation

{$R *.dfm}


 function GetPIMTOffset(const I: IInterface): integer;
// PIMT = Pointer to Interface Method Table
const
  AddByte = $04244483; // opcode for ADD DWORD PTR [ESP+4], Shortint
  AddLong = $04244481; // opcode for ADD DWORD PTR [ESP+4], Longint
type
  PAdjustSelfThunk = ^TAdjustSelfThunk;
  TAdjustSelfThunk = packed record
    case AddInstruction: longint of
      AddByte : (AdjustmentByte: shortint);
      AddLong : (AdjustmentLong: longint);
  end;
  PInterfaceMT = ^TInterfaceMT;
  TInterfaceMT = packed record
    QueryInterfaceThunk: PAdjustSelfThunk;
  end;
  TInterfaceRef = ^PInterfaceMT;
var
  QueryInterfaceThunk: PAdjustSelfThunk;
begin
  Result := -1;
  if Assigned(Pointer(I)) then
    try
      QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk;
      case QueryInterfaceThunk.AddInstruction of
        AddByte: Result := -QueryInterfaceThunk.AdjustmentByte;
        AddLong: Result := -QueryInterfaceThunk.AdjustmentLong;
      end;
    except
      // Protect against non-Delphi or invalid interface references
    end;
end;



function GetImplementingObject(const I: IInterface): TObject;
var
  Offset: integer;
begin
  Offset := GetPIMTOffset(I);
  if Offset > 0
  then Result := TObject(PChar(I) - Offset)
  else Result := nil;
end;



 function GetInterfaceEntry(const I: IInterface): PInterfaceEntry;
var
  Offset: integer;
  Instance: TObject;
  InterfaceTable: PInterfaceTable;
  j: integer;
  CurrentClass: TClass;
     pd: PVarData;
     cls:TClass;
  begin
 Result := nil;
try
  Offset := GetPIMTOffset(I);

  Instance :=
{$IF CompilerVersion >= 21.0}
   // I as TObject;
{$ELSE}
   // GetImplementingObject(I);
{$IFEND}
 // Exit;

  GetImplementingObject(I);
  //       Exit;
pd:=PVarData(I);

  if (Offset >= 0) and Assigned(Instance) then
  begin
    CurrentClass := Instance.ClassType;
    while Assigned(CurrentClass) do
    begin
      InterfaceTable := CurrentClass.GetInterfaceTable;
      if Assigned(InterfaceTable) then
        for j := 0 to InterfaceTable.EntryCount-1 do
        begin
          Result := @InterfaceTable.Entries[j];
          if Result.IOffset = Offset then
            Exit;
        end;
      CurrentClass := CurrentClass.ClassParent
    end;
  end;
  except
     ShowMessage('Error GetInterfaceEntry');
  Result := nil;

        end;

end;

function InterfaceTypeInfoOfGUID(const IID: WideString): PTypeInfo;
var
  Context : TRttiContext;
  ItemType : TRttiType;
  T: TRttiInterfaceType;
begin
  Result := nil;
{$IFDEF INTF_TYPEINFO_CACHE}
  if not Assigned(IntfTypeInfoCache) then
  begin
    IntfTypeInfoCache := TDictionary<TGUID, PTypeInfo>.Create;
{$ENDIF}
    for ItemType in Context.GetTypes do
    begin
      if ItemType is TRttiInterfaceType then
      begin
       T := TRttiInterfaceType(ItemType);
       if GUIDToString(T.GUID) = {StringToGUID}(IID) then
{$IFDEF INTF_TYPEINFO_CACHE}
         Result := T.Handle;
       IntfTypeInfoCache.AddOrSetValue(T.GUID, T.Handle);
{$ELSE}
         Exit(T.Handle);
{$ENDIF}
      end
    end;
{$IFDEF INTF_TYPEINFO_CACHE}
  end;
  if not Assigned(Result) then
    IntfTypeInfoCache.TryGetValue(IID, Result);
{$ENDIF}
end;
 function GetInterfaceIID(const I: IInterface; var IID: WideString): boolean;
var
//IIDS:String;
    pd: PVarData;
  InterfaceEntry: PInterfaceEntry;
begin
try


  InterfaceEntry := GetInterfaceEntry(I);

  Result := Assigned(InterfaceEntry);

    if Result then
iiD:=  GuidToString(InterfaceEntry.IID);

 except
  ShowMessage('Error GetInterfaceIID');
end;
end;


 function GetGUIDOleObject(ole:OleVariant): WideString;
var
 IIDS:WideString;
 Dispatch: IDispatch;
//  MyGuid: TGUID;
// IDD:OleVariant;
  pd: PVarData;
   MyInterface: IInterface;
 begin
 //MyGiud
 try
 pd := PVarData(@ole);
 //ShowMessage('IDispatch'+#13+VarToStr(pd^.VType) );
{if (pd^.VType = varObject) and  (pd^.VPointer <> nil) then
begin
try
                     // VarAsType(V,varVariant);
Dispatch :=IDispatch( pd.VDispatch);//VarAsType(V,varVariant));
pd:= PVarData(@Dispatch);
 
dispatch := nil;
end;
}
 dispatch:=IDispatch.Create;
// COM/Automation объект (IDispatch или IUnknown)
if (pd^.VType = varDispatch) or (pd^.VType = varUnknown) then
begin
// Попробуем получить IDispatch
try
                     // VarAsType(V,varVariant);
dispatch :=IDispatch( pd.VDispatch);//VarAsType(V,varVariant));
//pd:= PVarData(@dispatch);
   //   disp.ClassType.ClassName;
 //  if pd^.VType = varObject then
     //  Result :=' '+ TObject(pd^.VPointer).ClassName;
//ShowMessage('IDispatch'+#13+VarToStr(pd^.VType)+#13+Result);
except
dispatch := nil;
end;
end;

if Assigned(dispatch) then
begin
try
   MyInterface:=IInterface(TVarData(Ole).VUnknown );

       IIDS:='00000000-0000-0000-0000-000000000000';
     GetInterfaceIID(MyInterface,IIDS);
  result:=IIDS;
  except
  result:=' None GUID';
end;

end;
     except;
     result:='Error'
end;
end;
// end;
function VariantObjectClassName(const V: OleVariant): string;
var
pd: PVarData;
ti: ITypeInfo;
disp: IDispatch;
 basicType  : Integer;
sDoc, sHelpFile: PBStr;
helpCtx: PLongInt;
 typeString : string;
 Presult:PBStr;
begin


pd := PVarData(@V);
      ti:=ITypeInfo.Create;
 basicType := pd^.VType  and VarTypeMask;

  // ????????? ?????? ??? ???????????? ????
  case basicType of
    varEmpty     : typeString := 'varEmpty';
    varNull      : typeString := 'varNull';
    varSmallInt  : typeString := 'varSmallInt';
    varInteger   : typeString := 'varInteger';
    varSingle    : typeString := 'varSingle';
    varDouble    : typeString := 'varDouble';
    varCurrency  : typeString := 'varCurrency';
    varDate      : typeString := 'varDate';
    varOleStr    : typeString := 'varOleStr';
    varDispatch  : typeString := 'varDispatch';
    varError     : typeString := 'varError';
    varBoolean   : typeString := 'varBoolean';
    varVariant   : typeString := 'varVariant';
    varUnknown   : typeString := 'varUnknown';
    varByte      : typeString := 'varByte';
    varWord      : typeString := 'varWord';
    varLongWord  : typeString := 'varLongWord';
    varInt64     : typeString := 'varInt64';
    varStrArg    : typeString := 'varStrArg';
    varString    : typeString := 'varString';
    varAny       : typeString := 'varAny';
    varTypeMask  : typeString := 'varTypeMask';
    varObject    : typeString := 'varObject';
  end;

Result :={VarToStr(pd^.VType)+'|'+} typeString;// VarToStr(pd^.VType);

try
// Delphi-объект, упакованный как varObject
if (pd^.VType = varObject) and  (pd^.VPointer <> nil) then
begin
Result := TObject(pd^.VPointer).ClassName;
//Exit;
end;
except
    Result := ' IDispatch none typeinfo';

end;
disp:=IDispatch.Create;
// COM/Automation объект (IDispatch или IUnknown)
if (pd^.VType = varDispatch) or (pd^.VType = varUnknown) then
begin
// Попробуем получить IDispatch
try
                     // VarAsType(V,varVariant);
disp :=IDispatch( pd.VDispatch);//VarAsType(V,varVariant));
pd:= PVarData(@disp);
   //   disp.ClassType.ClassName;
   if pd^.VType = varObject then
       Result :=' '+ TObject(pd^.VPointer).ClassName;
//ShowMessage('IDispatch'+#13+VarToStr(pd^.VType)+#13+Result);
except
disp := nil;
end;
end;

           try
if Assigned(disp) then
begin
 // Получаем typeinfo (локаль можно заменить на LOCALE_USER_DEFAULT)
 if Succeeded(disp.GetTypeInfo(0, {LOCALE_USER_DEFAULT{}GetUserDefaultLCID, ti)) and Assigned(ti) then
  begin
  result:='';

            // // Получаем typeinfo (локаль можно заменить на LOCALE_USER_DEFAULT)
    // MEMBERID_NIL (-1) — имя типа
   ti.GetDocumentation(-1, @Result, @sDoc, nil, nil);
Result:=(result) ;
  //      ti.QualifiedClassName;
  // ShowMessage('Succeeded'+#13+Result);

   //    ti.GetDocumentation(MEMBERID_NIL, PResult, sDoc, helpCtx, sHelpFile);
  end
  else
    Result := 'INone';
        // }

       // disp.Free;
end;
           except
              Result := ' Error';// IDispatch typeinfo';
           end;

         result:=  UTF8ToWideString(result);
         result:=Copy(result,2,Length(result));

end;
procedure TForm1.Button1Click(Sender: TObject);
 var
 guid:WideString;
 ole:OleVariant ;
begin
guid:='Error';

ole:=CreateOleObject(ComboBox1.Text);//'Ip2Rec.Ip2ComRecord');
Label1.Caption :=VariantObjectClassName(ole);

//  GetInterfaceIID(ole,guid);
  Label2.Caption:=GetGUIDOleObject(ole);

end;

end.