Как определить название класса после вызова CreateOleObject

infopol · #1 12.06.2026, 06:47

Для передачи объекта в функцию нужно после определить название класса OleVariant.
var OleObject : OleVariant;
OleObject.ClassName - такого метода нету.

Код:

uses
SysUtils, Variants, ActiveX, Windows;

function VariantObjectClassName(const V: OleVariant): string;
var
pd: PVarData;
ti: ITypeInfo;
disp: IDispatch;
sDoc, sHelpFile: WideString;
helpCtx: Integer;
begin
Result := '';
pd := PVarData(@V);
// Delphi-объект, упакованный как varObject
if (pd^.VType = varObject) and (pd^.VPointer <> nil) then
begin
Result := TObject(pd^.VPointer).ClassName;
Exit;
end;

// COM/Automation объект (IDispatch или IUnknown)
if (pd^.VType = varDispatch) or (pd^.VType = varUnknown) then
begin
// Попробуем получить IDispatch
try
disp := IDispatch(V);
except
disp := nil;
end;


if Assigned(disp) then
begin
  // Получаем typeinfo (локаль можно заменить на LOCALE_USER_DEFAULT)
  if Succeeded(disp.GetTypeInfo(0, GetUserDefaultLCID, ti)) and Assigned(ti) then
  begin
    // MEMBERID_NIL (-1) — имя типа
    ti.GetDocumentation(MEMBERID_NIL, Result, sDoc, helpCtx, sHelpFile);
  end
  else
    Result := 'IDispatch без typeinfo';
end;

end;
end;

Админ: Пользуемся тегами при оформлении кода!
Это посоветовал ИИ. Но не работает

infopol · #2 12.06.2026, 14:52

Код:

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);

 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) ;
  // ShowMessage('Succeeded'+#13+Result);

   //    ti.GetDocumentation(MEMBERID_NIL, PResult, sDoc, helpCtx, sHelpFile);
  end
  else
    Result := 'IDispatch без typeinfo';
        // }

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


end;

пришлось перекодировать результат из UTF8 в Win

infopol · #3 Вчера, 20:23

Может кто подскажет,как получить 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.

infopol · #4 Сегодня, 16:44

Код:

 
function GetGUIDOleObject(ole:OleVariant): WideString;
var
TA: PTypeAttr;
 IIDS:WideString;
 Dispatch: IDispatch;
  MyGuid:TGUID;
// IDD:OleVariant;
 Guids:System.TGuid;
ti: ITypeInfo;
  pd: PVarData;
     unk: IUnknown;
   MyInterface: IInterface;
 begin
 //MyGiud
 try
 pd := PVarData(@ole);
 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));
except
dispatch := nil;
end;
end;

if Assigned(dispatch) then
begin
try
   unk := IUnknown(@ole);
   MyInterface:=  IInterface(PVarData(unk).VUnknown ) ;
if Succeeded( Dispatch.GetTypeInfo  (0, {LOCALE_USER_DEFAULT{}GetUserDefaultLCID, ti)) then
begin
//ti.Release;
if Succeeded(TI.GetTypeAttr(TA)) then
try

result:=(System.TGuid( TA^.guid).ToString) ; // GUID найден
 result:= StringReplace(result, '{', '',
                          [rfReplaceAll, rfIgnoreCase]);
result:= StringReplace(result, '}', '',
                          [rfReplaceAll, rfIgnoreCase]);

finally
TI.ReleaseTypeAttr(TA);

end;

end;
  except
  result:=' None GUID';
end;

end;
     except;
     result:='Error'
end;
end;

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты