开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
Ole2auto.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：33k
源码类别：

Delphi控件源码

开发平台：

Delphi

Ole2auto.pas：源码内容
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {         OLE2 Automation Controller                    }
  5. {                                                       }
  6. {         Copyright (c) 1995, 1996 AO ROSNO             }
  7. {         Copyright (c) 1997 Master-Bank                }
  8. {                                                       }
  9. {*******************************************************}
  11. unit Ole2Auto;
  13. interface
  15. {$I RX.INC}
  17. {$IFDEF WIN32}
  18. uses Windows, SysUtils, {$IFDEF RX_D3} ActiveX, ComObj {$ELSE}
  19.   Ole2, OleAuto, OleCtl {$ENDIF};
  20. {$ELSE}
  21. uses WinTypes, WinProcs, SysUtils, Ole2, Dispatch;
  22. {$ENDIF}
  24. const { Maximum number of dispatch arguments }
  25. {$IFDEF RX_D3}
  26.   MaxDispArgs = 64;
  27. {$ELSE}
  28.   MaxDispArgs = 32;
  29. {$ENDIF}
  31. {$IFNDEF WIN32}
  32. type
  33.   TDispID = DISPID;
  34.   PDispID = ^TDispID;
  35.   TDispParams = DISPPARAMS;
  36.   TLCID = LCID;
  37.   TExcepInfo = EXCEPINFO;
  38.   PDispIDList = ^TDispIDList;
  39.   TDispIDList = array[0..MaxDispArgs] of TDispID;
  40.   EOleError = class(Exception);
  41. {$ENDIF WIN32}
  43. {$IFNDEF RX_D3}
  44. type
  45.   EPropReadOnly = class(EOleError);
  46.   EPropWriteOnly = class(EOleError);
  47. {$ENDIF}
  49. {$IFNDEF WIN32}
  51. const
  52. { Primary language IDs. }
  53.   LANG_NEUTRAL                     = $00;
  55.   LANG_AFRIKAANS                   = $36;
  56.   LANG_ALBANIAN                    = $1C;
  57.   LANG_ARABIC                      = $01;
  58.   LANG_BASQUE                      = $2D;
  59.   LANG_BELARUSIAN                  = $23;
  60.   LANG_BULGARIAN                   = $02;
  61.   LANG_CATALAN                     = $03;
  62.   LANG_CHINESE                     = $04;
  63.   LANG_CROATIAN                    = $1A;
  64.   LANG_CZECH                       = $05;
  65.   LANG_DANISH                      = $06;
  66.   LANG_DUTCH                       = $13;
  67.   LANG_ENGLISH                     = $09;
  68.   LANG_ESTONIAN                    = $25;
  69.   LANG_FAEROESE                    = $38;
  70.   LANG_FARSI                       = $29;
  71.   LANG_FINNISH                     = $0B;
  72.   LANG_FRENCH                      = $0C;
  73.   LANG_GERMAN                      = $07;
  74.   LANG_GREEK                       = $08;
  75.   LANG_HEBREW                      = $0D;
  76.   LANG_HUNGARIAN                   = $0E;
  77.   LANG_ICELANDIC                   = $0F;
  78.   LANG_INDONESIAN                  = $21;
  79.   LANG_ITALIAN                     = $10;
  80.   LANG_JAPANESE                    = $11;
  81.   LANG_KOREAN                      = $12;
  82.   LANG_LATVIAN                     = $26;
  83.   LANG_LITHUANIAN                  = $27;
  84.   LANG_NORWEGIAN                   = $14;
  85.   LANG_POLISH                      = $15;
  86.   LANG_PORTUGUESE                  = $16;
  87.   LANG_ROMANIAN                    = $18;
  88.   LANG_RUSSIAN                     = $19;
  89.   LANG_SERBIAN                     = $1A;
  90.   LANG_SLOVAK                      = $1B;
  91.   LANG_SLOVENIAN                   = $24;
  92.   LANG_SPANISH                     = $0A;
  93.   LANG_SWEDISH                     = $1D;
  94.   LANG_THAI                        = $1E;
  95.   LANG_TURKISH                     = $1F;
  96.   LANG_UKRAINIAN                   = $22;
  97.   LANG_VIETNAMESE                  = $2A;
  99. { Sublanguage IDs. }
  100.   SUBLANG_NEUTRAL                  = $00;    { language neutral }
  101.   SUBLANG_DEFAULT                  = $01;    { user default }
  102.   SUBLANG_SYS_DEFAULT              = $02;    { system default }
  104.   SUBLANG_CHINESE_TRADITIONAL      = $01;    { Chinese (Taiwan) }
  105.   SUBLANG_CHINESE_SIMPLIFIED       = $02;    { Chinese (PR China) }
  106.   SUBLANG_CHINESE_HONGKONG         = $03;    { Chinese (Hong Kong) }
  107.   SUBLANG_CHINESE_SINGAPORE        = $04;    { Chinese (Singapore) }
  108.   SUBLANG_DUTCH                    = $01;    { Dutch }
  109.   SUBLANG_DUTCH_BELGIAN            = $02;    { Dutch (Belgian) }
  110.   SUBLANG_ENGLISH_US               = $01;    { English (USA) }
  111.   SUBLANG_ENGLISH_UK               = $02;    { English (UK) }
  112.   SUBLANG_ENGLISH_AUS              = $03;    { English (Australian) }
  113.   SUBLANG_ENGLISH_CAN              = $04;    { English (Canadian) }
  114.   SUBLANG_ENGLISH_NZ               = $05;    { English (New Zealand) }
  115.   SUBLANG_ENGLISH_EIRE             = $06;    { English (Irish) }
  116.   SUBLANG_FRENCH                   = $01;    { French }
  117.   SUBLANG_FRENCH_BELGIAN           = $02;    { French (Belgian) }
  118.   SUBLANG_FRENCH_CANADIAN          = $03;    { French (Canadian) }
  119.   SUBLANG_FRENCH_SWISS             = $04;    { French (Swiss) }
  120.   SUBLANG_GERMAN                   = $01;    { German }
  121.   SUBLANG_GERMAN_SWISS             = $02;    { German (Swiss) }
  122.   SUBLANG_GERMAN_AUSTRIAN          = $03;    { German (Austrian) }
  123.   SUBLANG_ITALIAN                  = $01;    { Italian }
  124.   SUBLANG_ITALIAN_SWISS            = $02;    { Italian (Swiss) }
  125.   SUBLANG_NORWEGIAN_BOKMAL         = $01;    { Norwegian (Bokmal) }
  126.   SUBLANG_NORWEGIAN_NYNORSK        = $02;    { Norwegian (Nynorsk) }
  127.   SUBLANG_PORTUGUESE               = $02;    { Portuguese }
  128.   SUBLANG_PORTUGUESE_BRAZILIAN     = $01;    { Portuguese (Brazilian) }
  129.   SUBLANG_SPANISH                  = $01;    { Spanish (Castilian) }
  130.   SUBLANG_SPANISH_MEXICAN          = $02;    { Spanish (Mexican) }
  131.   SUBLANG_SPANISH_MODERN           = $03;    { Spanish (Modern) }
  133. { Default System and User IDs for language and locale. }
  134.   LANG_SYSTEM_DEFAULT   = (SUBLANG_SYS_DEFAULT shl 10) or LANG_NEUTRAL;
  135.   LANG_USER_DEFAULT     = (SUBLANG_DEFAULT shl 10) or LANG_NEUTRAL;
  136.   LOCALE_SYSTEM_DEFAULT = (0 shl 16) or LANG_SYSTEM_DEFAULT;
  137.   LOCALE_USER_DEFAULT   = (0 shl 16) or LANG_USER_DEFAULT;
  139. { OLE control status codes }
  140.   CTL_E_ILLEGALFUNCTIONCALL       = $800A0000 + 5;
  141.   CTL_E_OVERFLOW                  = $800A0000 + 6;
  142.   CTL_E_OUTOFMEMORY               = $800A0000 + 7;
  143.   CTL_E_DIVISIONBYZERO            = $800A0000 + 11;
  144.   CTL_E_OUTOFSTRINGSPACE          = $800A0000 + 14;
  145.   CTL_E_OUTOFSTACKSPACE           = $800A0000 + 28;
  146.   CTL_E_BADFILENAMEORNUMBER       = $800A0000 + 52;
  147.   CTL_E_FILENOTFOUND              = $800A0000 + 53;
  148.   CTL_E_BADFILEMODE               = $800A0000 + 54;
  149.   CTL_E_FILEALREADYOPEN           = $800A0000 + 55;
  150.   CTL_E_DEVICEIOERROR             = $800A0000 + 57;
  151.   CTL_E_FILEALREADYEXISTS         = $800A0000 + 58;
  152.   CTL_E_BADRECORDLENGTH           = $800A0000 + 59;
  153.   CTL_E_DISKFULL                  = $800A0000 + 61;
  154.   CTL_E_BADRECORDNUMBER           = $800A0000 + 63;
  155.   CTL_E_BADFILENAME               = $800A0000 + 64;
  156.   CTL_E_TOOMANYFILES              = $800A0000 + 67;
  157.   CTL_E_DEVICEUNAVAILABLE         = $800A0000 + 68;
  158.   CTL_E_PERMISSIONDENIED          = $800A0000 + 70;
  159.   CTL_E_DISKNOTREADY              = $800A0000 + 71;
  160.   CTL_E_PATHFILEACCESSERROR       = $800A0000 + 75;
  161.   CTL_E_PATHNOTFOUND              = $800A0000 + 76;
  162.   CTL_E_INVALIDPATTERNSTRING      = $800A0000 + 93;
  163.   CTL_E_INVALIDUSEOFNULL          = $800A0000 + 94;
  164.   CTL_E_INVALIDFILEFORMAT         = $800A0000 + 321;
  165.   CTL_E_INVALIDPROPERTYVALUE      = $800A0000 + 380;
  166.   CTL_E_INVALIDPROPERTYARRAYINDEX = $800A0000 + 381;
  167.   CTL_E_SETNOTSUPPORTEDATRUNTIME  = $800A0000 + 382;
  168.   CTL_E_SETNOTSUPPORTED           = $800A0000 + 383;
  169.   CTL_E_NEEDPROPERTYARRAYINDEX    = $800A0000 + 385;
  170.   CTL_E_SETNOTPERMITTED           = $800A0000 + 387;
  171.   CTL_E_GETNOTSUPPORTEDATRUNTIME  = $800A0000 + 393;
  172.   CTL_E_GETNOTSUPPORTED           = $800A0000 + 394;
  173.   CTL_E_PROPERTYNOTFOUND          = $800A0000 + 422;
  174.   CTL_E_INVALIDCLIPBOARDFORMAT    = $800A0000 + 460;
  175.   CTL_E_INVALIDPICTURE            = $800A0000 + 481;
  176.   CTL_E_PRINTERERROR              = $800A0000 + 482;
  177.   CTL_E_CANTSAVEFILETOTEMP        = $800A0000 + 735;
  178.   CTL_E_SEARCHTEXTNOTFOUND        = $800A0000 + 744;
  179.   CTL_E_REPLACEMENTSTOOLONG       = $800A0000 + 746;
  180.   CTL_E_CUSTOM_FIRST              = $800A0000 + 600;
  182. {$ENDIF WIN32}
  184. type
  186. { OLE2 Automation Controller }
  188.   TOleController = class(TObject)
  189.   private
  190.     FLocale: TLCID;
  191.     FObject: Variant;
  192.     FRetValue: Variant;
  193.     function CallMethod(ID: TDispID; const Params: array of const;
  194.       NeedResult: Boolean): PVariant;
  195.     function CallMethodNamedParams(const IDs: TDispIDList;
  196.       const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
  197.     function CallMethodNoParams(ID: TDispID; NeedResult: Boolean): PVariant;
  198.     function Invoke(dispidMember: TDispID; wFlags: Word;
  199.       var pdispparams: TDispParams; Res: PVariant): PVariant;
  200.     function NameToDispID(const AName: string): TDispID;
  201.     function NameToDispIDs(const AName: string;
  202.       const AParams: array of string; Dest: PDispIDList): PDispIDList;
  203.   protected
  204.     procedure ClearObject; virtual;
  205.   public
  206.     constructor Create;
  207.     destructor Destroy; override;
  208.     { create or assign OLE objects }
  209.     procedure CreateObject(const ClassName: string); virtual;
  210.     procedure AssignIDispatch(V: Variant); virtual;
  211.     procedure GetActiveObject(const ClassName: string); virtual;
  212.     { get/set properties of OLE object by ID }
  213.     function GetPropertyByID(ID: TDispID): PVariant;
  214.     procedure SetPropertyByID(ID: TDispID; const Prop: array of const);
  215.     { get/set properties of OLE object }
  216.     function GetProperty(const AName: string): PVariant;
  217.     procedure SetProperty(const AName: string; const Prop: array of const);
  218.     { call OLE functions by IDs }
  219.     function CallFunctionByID(ID: TDispID; const Params: array of const): PVariant;
  220.     function CallFunctionByIDsNamedParams(const IDs: TDispIDList;
  221.       const Params: array of const; Cnt: Byte): PVariant;
  222.     function CallFunctionNoParamsByID(ID: TDispID): PVariant;
  223.     { call OLE procedures by ID }
  224.     procedure CallProcedureByID(ID: TDispID; const Params: array of const);
  225.     procedure CallProcedureByIDsNamedParams(const IDs: TDispIDList;
  226.       const Params: array of const; Cnt: Byte);
  227.     procedure CallProcedureNoParamsByID(ID: TDispID);
  228.     { call OLE functions }
  229.     function CallFunction(const AName: string; const Params: array of const): PVariant;
  230.     function CallFunctionNamedParams(const AName: string; const Params: array of const;
  231.       const ParamNames: array of string): PVariant;
  232.     function CallFunctionNoParams(const AName: string): PVariant;
  233.     { call OLE procedures }
  234.     procedure CallProcedure(const AName: string; const Params: array of const);
  235.     procedure CallProcedureNamedParams(const AName: string; const Params: array of const;
  236.       const ParamNames: array of string);
  237.     procedure CallProcedureNoParams(const AName: string);
  238.     { locale }
  239.     procedure SetLocale(PrimaryLangID, SubLangID: Word);
  240.     property Locale: TLCID read FLocale write FLocale;
  241.     property OleObject: Variant read FObject;
  242.   end;
  244. procedure InitOLE;
  245. procedure DoneOLE;
  246. function OleInitialized: Boolean;
  248. function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
  249. function MakeLCID(LangID: Word): TLCID;
  250. function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
  251. function ExtractLangID(LCID: TLCID): Word;
  252. function ExtractSubLangID(LCID: TLCID): Word;
  254. {$IFNDEF WIN32}
  256. procedure OleCheck(OleResult: HResult);
  258. { OLE string support }
  259. function OleStrToString(Source: BSTR): string;
  260. function StringToOleStr(const Source: string): BSTR;
  261. function StringToClassID(const S: string): CLSID;
  262. function ClassIDToString(const CLSID: CLSID): string;
  264. { Create or get active OLE object for a given a class name }
  265. function CreateOleObject(const ClassName: string): Variant;
  266. function GetActiveOleObject(const ClassName: string): Variant;
  268. {$ENDIF WIN32}
  270. implementation
  272. uses Forms;
  274. {$IFDEF RX_D3}
  275. resourcestring
  276. {$ELSE}
  277. const
  278. {$ENDIF}
  279.   SOleInvalidVer   = 'Invalid OLE library version';
  280.   SOleInitFailed   = 'OLE Library initialization failed. Error code: %.8xH';
  281.   SOleNotInit      = 'OLE2 Library not initialized';
  282.   SOleInvalidParam = 'Invalid parameter value';
  283.   SOleNotSupport   = 'Method or property %s not supported by OLE object';
  284.   SOleNotReference = 'Variant does not reference an OLE automation object';
  285. {$IFNDEF RX_D3}
  286.   SOleError        = 'OLE2 error occured. Error code: %.8xH';
  287. {$ENDIF}
  289. const
  290.   FOleInitialized: Boolean = False;
  292. const
  293. { OLE2 Version }
  294.   RMJ =   0;
  295.   RMM =  23;
  296.   RUP = 639;
  298. const
  299.   DISPATCH_METHODNOPARAM = DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  300.   DISPATCH_METHODPARAMS = DISPATCH_METHOD
  301.     {$IFDEF WIN32} or DISPATCH_PROPERTYGET {$ENDIF};
  303. {$IFDEF WIN32}
  305. function FailedHR(hr: HResult): Boolean;
  306. begin
  307.   Result := Failed(hr);
  308. end;
  310. {$ELSE WIN32}
  312. { Standard OLE class pathes }
  314. type
  315.   IDispatch = class(IUnknown)
  316.     function GetTypeInfoCount(var pctinfo: Integer): HResult; virtual; cdecl; export; abstract;
  317.     function GetTypeInfo(itinfo: Integer; TLCID: TLCID; var pptinfo: ITypeInfo): HResult; virtual; cdecl; export; abstract;
  318.     function GetIDsOfNames(const riid: IID; var rgszNames: PChar;
  319.       cNames: Integer; TLCID: TLCID; rgdispid: PDispID): HResult; virtual; cdecl; export; abstract;
  320.     function Invoke(dispidMember: TDispID; const riid: IID; TLCID: TLCID;
  321.       wFlags: Word; var pdispparams: TDispParams; pvarResult: PVARIANT;
  322.       var pexcepinfo: TExcepInfo; var puArgErr: Integer): HResult; virtual; cdecl; export; abstract;
  323.   end;
  325. function DispInvoke(_this: Pointer; ptinfo: ITypeInfo; dispidMember: TDispID;
  326.   wFlags: Word; var pparams: TDispParams; pvarResult: PVARIANT;
  327.   var pexcepinfo: TExcepInfo; var puArgErr: Integer): HResult; far; external 'ole2disp';
  328. function DispGetIDsOfNames(ptinfo: ITypeInfo; var rgszNames: PChar;
  329.   cNames: Integer; rgdispid: PDispID): HResult; far; external 'ole2disp';
  331. function GUID_NULL: GUID;
  332. begin
  333.   Result := IID_NULL;
  334. end;
  336. {$ENDIF WIN32}
  338. { Standard OLE Library initialization code }
  340. procedure InitOLE;
  341. var
  342.   dwVer: Longint;
  343.   HRes: HResult;
  344. begin
  345.   if FOleInitialized then Exit;
  346.   dwVer := Longint(CoBuildVersion);
  347.   if (RMM <> HiWord(dwVer)) or (RUP > LoWord(dwVer)) then
  348.     raise EOleError.Create(SOleInvalidVer)
  349.   else begin
  350.     HRes := OleInitialize(nil);
  351.     if FailedHR(HRes) then
  352.       raise EOleError.CreateFmt(SOleInitFailed, [Longint(HRes)])
  353.     else FOleInitialized := True;
  354.   end;
  355. end;
  357. { Standard OLE Library exit code }
  359. procedure DoneOLE;
  360. begin
  361.   if FOleInitialized then OleUninitialize;
  362.   FOleInitialized := False;
  363. end;
  365. function OleInitialized: Boolean;
  366. begin
  367.   Result := FOleInitialized;
  368. end;
  370. procedure CheckOleInitialized;
  371. begin
  372.   if not FOleInitialized then raise EOleError.Create(SOleNotInit);
  373. end;
  375. {$IFNDEF RX_D3}
  376. function OleErrorMsg(ErrorCode: HResult): string;
  377. begin
  378.   FmtStr(Result, SOleError, [Longint(ErrorCode)]);
  379. end;
  380. {$ENDIF}
  382. {$IFNDEF WIN32}
  384. procedure OleError(ErrorCode: HResult);
  385. begin
  386.   raise EOleError.Create(OleErrorMsg(ErrorCode));
  387. end;
  389. { Raise EOleError exception if result code indicates an error }
  391. procedure OleCheck(OleResult: HResult);
  392. begin
  393.   if FailedHR(OleResult) then OleError(OleResult);
  394. end;
  396. {$ENDIF WIN32}
  398. { Raise exception given an OLE return code and TExcepInfo structure }
  400. procedure DispInvokeError(Status: HResult; const ExcepInfo: TExcepInfo);
  401. {$IFDEF RX_D3}
  402. begin
  403.   DispatchInvokeError(Status, ExcepInfo);
  404. {$ELSE}
  405. var
  406.   EClass: ExceptClass;
  407.   Message: string;
  408. begin
  409.   EClass := EOleError;
  410.   if Longint(Status) <> DISP_E_EXCEPTION then
  411.     Message := OleErrorMsg(Status)
  412.   else
  413.     with ExcepInfo do
  414.     begin
  415.       try
  416.         if (scode = CTL_E_SETNOTSUPPORTED) or
  417.           (scode = CTL_E_SETNOTSUPPORTEDATRUNTIME) then
  418.             EClass := EPropReadOnly
  419.         else if (scode = CTL_E_GETNOTSUPPORTED) or
  420.           (scode = CTL_E_GETNOTSUPPORTEDATRUNTIME) then
  421.             EClass := EPropWriteOnly;
  422.         if bstrDescription <> nil then begin
  423.           Message := OleStrToString(bstrDescription);
  424.           while (Length(Message) > 0) and
  425.             (Message[Length(Message)] in [#0..#32, '.']) do
  426.             Delete(Message, Length(Message), 1);
  427.         end;
  428.       finally
  429.         if bstrSource <> nil then SysFreeString(bstrSource);
  430.         if bstrDescription <> nil then SysFreeString(bstrDescription);
  431.         if bstrHelpFile <> nil then SysFreeString(bstrHelpFile);
  432.       end;
  433.     end;
  434.   if Message = '' then Message := OleErrorMsg(Status);
  435.   raise EClass.Create(Message);
  436. {$ENDIF RX_D3}
  437. end;
  439. {$IFNDEF WIN32}
  441. { Convert a string to a class ID }
  443. function StringToClassID(const S: string): CLSID;
  444. var
  445.   CharBuf: array[0..64] of Char;
  446. begin
  447.   OleCheck(CLSIDFromString(StrPLCopy(CharBuf, S, SizeOf(CharBuf) - 1),
  448.     Result));
  449. end;
  451. { Convert a class ID to a string }
  453. function ClassIDToString(const CLSID: CLSID): string;
  454. var
  455.   P: PChar;
  456.   Malloc: IMalloc;
  457. begin
  458.   OleCheck(CoGetMalloc(MEMCTX_TASK, Malloc));
  459.   OleCheck(StringFromCLSID(CLSID, P));
  460.   Result := StrPas(P);
  461.   Malloc.Free(P);
  462. end;
  464. { Create an OLE object variant given an IDispatch }
  466. function VarFromInterface(Unknown: IUnknown): Variant;
  467. var
  468.   Disp: IDispatch;
  469. begin
  470.   VariantClear(VARIANTARG(Result));
  471.   VariantInit(VARIANTARG(Result));
  472.   try
  473.     if Unknown <> nil then begin
  474.       OleCheck(Unknown.QueryInterface(IID_IDispatch, Disp));
  475.       Result.VT := VT_DISPATCH;
  476.       Result.pdispVal := Dispatch.IDispatch(Disp);
  477.     end;
  478.   except
  479.     VariantClear(VARIANTARG(Result));
  480.     raise;
  481.   end;
  482. end;
  484. { Return OLE object stored in a variant }
  486. function VarToInterface(const V: Variant): IDispatch;
  487. begin
  488.   Result := nil;
  489.   if V.VT = VT_DISPATCH then
  490.     Result := IDispatch(V.pdispVal)
  491.   else if V.VT = (VT_DISPATCH or VT_BYREF) then
  492.     Result := IDispatch(V.ppdispVal^);
  493.   if Result = nil then raise EOleError.Create(SOleNotReference);
  494. end;
  496. { Create an OLE object variant given a class name }
  498. function CreateOleObject(const ClassName: string): Variant;
  499. var
  500.   Unknown: IUnknown;
  501.   ClassID: CLSID;
  502.   CharBuf: array[0..127] of Char;
  503. begin
  504.   StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  505.   OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  506.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  507.     CLSCTX_LOCAL_SERVER, IID_IUnknown, Unknown));
  508.   try
  509.     Result := VarFromInterface(Unknown);
  510.   finally
  511.     Unknown.Release;
  512.   end;
  513. end;
  515. { Get active OLE object for a given class name }
  517. function GetActiveOleObject(const ClassName: string): Variant;
  518. var
  519.   Unknown: IUnknown;
  520.   ClassID: CLSID;
  521.   CharBuf: array[0..127] of Char;
  522. begin
  523.   StrPLCopy(CharBuf, ClassName, SizeOf(CharBuf) - 1);
  524.   OleCheck(CLSIDFromProgID(@CharBuf, ClassID));
  525.   OleCheck(GetActiveObject(ClassID, nil, Unknown));
  526.   try
  527.     Result := VarFromInterface(Unknown);
  528.   finally
  529.     Unknown.Release;
  530.   end;
  531. end;
  533. { OLE string support }
  535. function OleStrToString(Source: BSTR): string;
  536. begin
  537.   Result := StrPas(Source);
  538. end;
  540. function StringToOleStr(const Source: string): BSTR;
  541. var
  542.   SourceLen: Integer;
  543.   CharBuf: array[0..255] of Char;
  544. begin
  545.   SourceLen := Length(Source);
  546.   if SourceLen > 0 then begin
  547.     StrPLCopy(CharBuf, Source, SizeOf(CharBuf) - 1);
  548.     Result := SysAllocStringLen(CharBuf, SourceLen);
  549.   end
  550.   else Result := nil;
  551. end;
  553. {$ELSE}
  554.  {$IFDEF RX_D3}
  556. { Return OLE object stored in a variant }
  558. function VarToInterface(const V: Variant): IDispatch;
  559. begin
  560.   Result := nil;
  561.   if TVarData(V).VType = varDispatch then
  562.     Result := IDispatch(TVarData(V).VDispatch)
  563.   else if TVarData(V).VType = (varDispatch or varByRef) then
  564.     Result := IDispatch(Pointer(TVarData(V).VPointer^));
  565.   if Result = nil then raise EOleError.Create(SOleNotReference);
  566. end;
  568.  {$ENDIF}
  569. {$ENDIF}
  571. { Assign Variant }
  573. procedure AssignVariant(
  574.   var Dest: {$IFDEF WIN32} TVariantArg; {$ELSE} Variant; {$ENDIF}
  575.   const Value: TVarRec);
  576. begin
  577. {$IFNDEF WIN32}
  578.   VariantInit(VARIANTARG(Dest));
  579.   try
  580. {$ENDIF}
  581.     with Value do
  582.       case VType of
  583.         vtInteger:
  584.           begin
  585.             Dest.vt := VT_I4;
  586.             Dest.lVal := VInteger;
  587.           end;
  588.         vtBoolean:
  589.           begin
  590.             Dest.vt := VT_BOOL;
  591.             Dest.vbool := VBoolean;
  592.           end;
  593.         vtChar:
  594.           begin
  595.             Dest.vt := VT_BSTR;
  596.             Dest.bstrVal := StringToOleStr(VChar);
  597.           end;
  598.         vtExtended:
  599.           begin
  600.             Dest.vt := VT_R8;
  601.             Dest.dblVal := VExtended^;
  602.           end;
  603.         vtString:
  604.           begin
  605.             Dest.vt := VT_BSTR;
  606.             Dest.bstrVal := StringToOleStr(VString^);
  607.           end;
  608.         vtPointer:
  609.           if VPointer = nil then begin
  610.             Dest.vt := VT_NULL;
  611.             Dest.byRef := nil;
  612.           end
  613.           else begin
  614.             Dest.vt := VT_BYREF;
  615.             Dest.byRef := VPointer;
  616.           end;
  617.         vtPChar:
  618.           begin
  619.             Dest.vt := VT_BSTR;
  620.             Dest.bstrVal := StringToOleStr(StrPas(VPChar));
  621.           end;
  622.         vtObject:
  623.           begin
  624.             Dest.vt := VT_BYREF;
  625.             Dest.byRef := VObject;
  626.           end;
  627. {$IFDEF WIN32}
  628.         vtClass:
  629.           begin
  630.             Dest.vt := VT_BYREF;
  631.             Dest.byRef := VClass;
  632.           end;
  633.         vtWideChar:
  634.           begin
  635.             Dest.vt := VT_BSTR;
  636.             Dest.bstrVal := @VWideChar;
  637.           end;
  638.         vtPWideChar:
  639.           begin
  640.             Dest.vt := VT_BSTR;
  641.             Dest.bstrVal := VPWideChar;
  642.           end;
  643.         vtAnsiString:
  644.           begin
  645.             Dest.vt := VT_BSTR;
  646.             Dest.bstrVal := StringToOleStr(string(VAnsiString));
  647.           end;
  648.         vtCurrency:
  649.           begin
  650.             Dest.vt := VT_CY;
  651.             Dest.cyVal := VCurrency^;
  652.           end;
  653.         vtVariant:
  654.           begin
  655.             Dest.vt := VT_BYREF or VT_VARIANT;
  656.             Dest.pvarVal := VVariant;
  657.           end;
  658. {$ENDIF WIN32}
  659. {$IFDEF RX_D4}
  660.         vtInterface:
  661.           begin
  662.             Dest.vt := VT_UNKNOWN or VT_BYREF;
  663.             Dest.byRef := VInterface;
  664.           end;
  665.         vtInt64:
  666.           begin
  667.             Dest.vt := VT_I8 or VT_BYREF;
  668.             Dest.byRef := VInt64;
  669.           end;
  670. {$ENDIF RX_D4}
  671.         else raise EOleError.Create(SOleInvalidParam);
  672.       end;
  673. {$IFNDEF WIN32}
  674.   except
  675.     VariantClear(VARIANTARG(Dest));
  676.     raise;
  677.   end;
  678. {$ENDIF}
  679. end;
  681. { TOleController }
  683. constructor TOleController.Create;
  684. begin
  685.   inherited Create;
  686. {$IFDEF WIN32}
  687.   FLocale := GetThreadLocale;
  688. {$ELSE}
  689.   FLocale := LOCALE_SYSTEM_DEFAULT;
  690. {$ENDIF}
  691.   try
  692.     InitOLE;
  693.   except
  694.     Application.HandleException(Self);
  695.   end;
  696. end;
  698. destructor TOleController.Destroy;
  699. begin
  700.   if FOleInitialized then ClearObject;
  701.   inherited Destroy;
  702. end;
  704. procedure TOleController.CreateObject(const ClassName: string);
  705. begin
  706.   CheckOleInitialized;
  707.   ClearObject;
  708.   FObject := CreateOleObject(ClassName);
  709. end;
  711. procedure TOleController.GetActiveObject(const ClassName: string);
  712. begin
  713.   CheckOleInitialized;
  714.   ClearObject;
  715.   FObject := GetActiveOleObject(ClassName);
  716. end;
  718. procedure TOleController.AssignIDispatch(V: Variant);
  719. begin
  720.   CheckOleInitialized;
  721.   ClearObject;
  722.   VarToInterface(V);
  723. {$IFDEF WIN32}
  724.   VarCopy(FObject, V);
  725. {$ELSE}
  726.   VariantCopy(VARIANTARG(FObject), V);
  727. {$ENDIF}
  728. end;
  730. procedure TOleController.ClearObject;
  731. begin
  732. {$IFDEF WIN32}
  733.   VarClear(FRetValue);
  734.   VarClear(FObject);
  735. {$ELSE}
  736.   VariantClear(VARIANTARG(FRetValue));
  737.   VariantClear(VARIANTARG(FObject));
  738. {$ENDIF}
  739. end;
  741. function TOleController.NameToDispID(const AName: string): TDispID;
  742. var
  743. {$IFDEF WIN32}
  744.   CharBuf: array[0..255] of WideChar;
  745.   P: array[0..0] of PWideChar;
  746. {$ELSE}
  747.   CharBuf: array[0..255] of Char;
  748.   P: PChar;
  749. {$ENDIF}
  750. begin
  751.   CheckOleInitialized;
  752. {$IFDEF WIN32}
  753.   StringToWideChar(AName, @CharBuf, 256);
  754.   P[0] := @CharBuf[0];
  755. {$ELSE}
  756.   StrPLCopy(CharBuf, AName, SizeOf(CharBuf) - 1);
  757.   P := @CharBuf;
  758. {$ENDIF}
  759.   if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
  760.     {$IFDEF WIN32} @P, {$ELSE} P, {$ENDIF} 1, FLocale, @Result)) then
  761.     raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  762. end;
  764. function TOleController.NameToDispIDs(const AName: string;
  765.   const AParams: array of string; Dest: PDispIDList): PDispIDList;
  766. var
  767. {$IFDEF WIN32}
  768.   CharBuf: array[0..MaxDispArgs] of PWideChar;
  769.   Size: Integer;
  770. {$ELSE}
  771.   CharBuf: array[0..MaxDispArgs] of PChar;
  772. {$ENDIF}
  773.   I: Byte;
  774. begin
  775.   Result := Dest;
  776.   CheckOleInitialized;
  777. {$IFDEF WIN32}
  778.   Size := Length(AName) + 1;
  779.   GetMem(CharBuf[0], Size * SizeOf(WideChar));
  780.   StringToWideChar(AName, CharBuf[0], Size);
  781.   for I := 0 to High(AParams) do begin
  782.     Size := Length(AParams[I]) + 1;
  783.     GetMem(CharBuf[I + 1], Size * SizeOf(WideChar));
  784.     StringToWideChar(AParams[I], CharBuf[I + 1], Size);
  785.   end;
  786. {$ELSE}
  787.   CharBuf[0] := StrPCopy(StrAlloc(Length(AName) + 1), AName);
  788.   for I := 0 to High(AParams) do
  789.     CharBuf[I + 1] := StrPCopy(StrAlloc(Length(AParams[I]) + 1), AParams[I]);
  790. {$ENDIF}
  791.   try
  792.     if FailedHR(VarToInterface(FObject).GetIDsOfNames(GUID_NULL,
  793.       {$IFDEF WIN32} @CharBuf, {$ELSE} CharBuf[0], {$ENDIF}
  794.       High(AParams) + 2, FLocale, @Result^[0]))
  795.     then
  796.       raise EOleError.CreateFmt(SOleNotSupport, [AName]);
  797.   finally
  798. {$IFDEF WIN32}
  799.     for I := 0 to High(AParams) + 1 do FreeMem(CharBuf[I]);
  800. {$ELSE}
  801.     for I := 0 to High(AParams) + 1 do StrDispose(CharBuf[I]);
  802. {$ENDIF}
  803.   end;
  804. end;
  806. function TOleController.Invoke(dispidMember: TDispID; wFlags: Word;
  807.   var pdispparams: TDispParams; Res: PVariant): PVariant;
  808. var
  809.   pexcepinfo: TExcepInfo;
  810.   puArgErr: Integer;
  811.   HRes: HResult;
  812. begin
  813. {$IFDEF WIN32}
  814.   if Res <> nil then VarClear(Res^);
  815.   try
  816.     HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
  817.       FLocale, wFlags, pdispparams, Res, @pexcepinfo, @puArgErr);
  818.   except
  819.     if Res <> nil then VarClear(Res^);
  820.     raise;
  821.   end;
  822. {$ELSE}
  823.   if Res <> nil then begin
  824.     VariantClear(VARIANTARG(Res^));
  825.     VariantInit(VARIANTARG(Res^));
  826.   end;
  827.   try
  828.     HRes := VarToInterface(FObject).Invoke(dispidMember, GUID_NULL,
  829.       FLocale, wFlags, pdispparams, Res, pexcepinfo, puArgErr);
  830.   except
  831.     if Res <> nil then VariantClear(VARIANTARG(Res^));
  832.     raise;
  833.   end;
  834. {$ENDIF}
  835.   if FailedHR(HRes) then DispInvokeError(HRes, pexcepinfo);
  836.   Result := Res;
  837. end;
  839. function TOleController.CallMethodNoParams(ID: TDispID;
  840.   NeedResult: Boolean): PVariant;
  841. const
  842.   Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil; cArgs: 0;
  843.     cNamedArgs: 0);
  844. begin
  845.   CheckOleInitialized;
  846.   if NeedResult then
  847.     Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, @FRetValue)
  848.   else
  849.     Result := Invoke(ID, DISPATCH_METHODNOPARAM, Disp, nil);
  850. end;
  852. function TOleController.CallMethod(ID: TDispID; const Params: array of const;
  853.   NeedResult: Boolean): PVariant;
  854. var
  855.   Disp: TDispParams;
  856.   ArgCnt, I: Integer;
  857. {$IFDEF WIN32}
  858.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  859. {$ELSE}
  860.   Args: array[0..MaxDispArgs - 1] of Variant;
  861. {$ENDIF}
  862. begin
  863.   CheckOleInitialized;
  864.   ArgCnt := 0;
  865.   try
  866.     for I := 0 to High(Params) do begin
  867.       AssignVariant(Args[I], Params[I]);
  868.       Inc(ArgCnt);
  869.       if ArgCnt >= MaxDispArgs then Break;
  870.     end;
  871.     with Disp do begin
  872.       if ArgCnt = 0 then rgvarg := nil
  873.       else rgvarg := @Args;
  874.       rgdispidNamedArgs := nil;
  875.       cArgs := ArgCnt;
  876.       cNamedArgs := 0;
  877.     end;
  878.     if NeedResult then
  879.       Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, @FRetValue)
  880.     else
  881.       Result := Invoke(ID, DISPATCH_METHODPARAMS, Disp, nil);
  882.   finally
  883. {$IFNDEF WIN32}
  884.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  885. {$ENDIF}
  886.   end;
  887. end;
  889. function TOleController.CallMethodNamedParams(const IDs: TDispIDList;
  890.   const Params: array of const; Cnt: Byte; NeedResult: Boolean): PVariant;
  891. var
  892.   Disp: TDispParams;
  893.   ArgCnt, I: Integer;
  894. {$IFDEF WIN32}
  895.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  896. {$ELSE}
  897.   Args: array[0..MaxDispArgs - 1] of Variant;
  898. {$ENDIF}
  899. begin
  900.   CheckOleInitialized;
  901.   ArgCnt := 0;
  902.   try
  903.     for I := 0 to High(Params) do begin
  904.       AssignVariant(Args[I], Params[I]);
  905.       Inc(ArgCnt);
  906.       if ArgCnt >= MaxDispArgs then Break;
  907.     end;
  908.     with Disp do begin
  909.       if ArgCnt = 0 then rgvarg := nil
  910.       else rgvarg := @Args;
  911.       if Cnt = 0 then rgdispidNamedArgs := nil
  912.       else rgdispidNamedArgs := @IDs[1];
  913.       cArgs := ArgCnt;
  914.       cNamedArgs := Cnt;
  915.     end;
  916.     if NeedResult then
  917.       Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, @FRetValue)
  918.     else
  919.       Result := Invoke(IDs[0], DISPATCH_METHODPARAMS, Disp, nil);
  920.   finally
  921. {$IFNDEF WIN32}
  922.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  923. {$ENDIF}
  924.   end;
  925. end;
  927. procedure TOleController.SetPropertyByID(ID: TDispID; const Prop: array of const);
  928. const
  929.   NameArg: TDispID = DISPID_PROPERTYPUT;
  930. var
  931.   Disp: TDispParams;
  932.   ArgCnt, I: Integer;
  933. {$IFDEF WIN32}
  934.   Args: array[0..MaxDispArgs - 1] of TVariantArg;
  935. {$ELSE}
  936.   Args: array[0..MaxDispArgs - 1] of Variant;
  937. {$ENDIF}
  938. begin
  939.   CheckOleInitialized;
  940.   ArgCnt := 0;
  941.   try
  942.     for I := 0 to High(Prop) do begin
  943.       AssignVariant(Args[I], Prop[I]);
  944.       Inc(ArgCnt);
  945.       if ArgCnt >= MaxDispArgs then Break;
  946.     end;
  947.     with Disp do begin
  948.       rgvarg := @Args;
  949.       rgdispidNamedArgs := @NameArg;
  950.       cArgs := ArgCnt;
  951.       cNamedArgs := 1;
  952.     end;
  953.     Invoke(ID, DISPATCH_PROPERTYPUT, Disp, nil);
  954.   finally
  955. {$IFNDEF WIN32}
  956.     for I := 0 to ArgCnt - 1 do VariantClear(VARIANTARG(Args[I]));
  957. {$ENDIF}
  958.   end;
  959. end;
  961. function TOleController.GetPropertyByID(ID: TDispID): PVariant;
  962. const
  963.   Disp: TDispParams = (rgvarg: nil; rgdispidNamedArgs: nil;
  964.     cArgs: 0; cNamedArgs: 0);
  965. begin
  966.   CheckOleInitialized;
  967.   Result := Invoke(ID, DISPATCH_PROPERTYGET, Disp, @FRetValue);
  968. end;
  970. procedure TOleController.CallProcedureByID(ID: TDispID; const Params: array of const);
  971. begin
  972.   CallMethod(ID, Params, False);
  973. end;
  975. function TOleController.CallFunctionByID(ID: TDispID;
  976.   const Params: array of const): PVariant;
  977. begin
  978.   Result := CallMethod(ID, Params, True);
  979. end;
  981. procedure TOleController.CallProcedureByIDsNamedParams(const IDs: TDispIDList;
  982.   const Params: array of const; Cnt: Byte);
  983. begin
  984.   CallMethodNamedParams(IDs, Params, Cnt, False);
  985. end;
  987. function TOleController.CallFunctionByIDsNamedParams(const IDs: TDispIDList;
  988.   const Params: array of const; Cnt: Byte): PVariant;
  989. begin
  990.   Result := CallMethodNamedParams(IDs, Params, Cnt, True);
  991. end;
  993. procedure TOleController.CallProcedureNoParamsByID(ID: TDispID);
  994. begin
  995.   CallMethodNoParams(ID, False);
  996. end;
  998. function TOleController.CallFunctionNoParamsByID(ID: TDispID): PVariant;
  999. begin
  1000.   Result := CallMethodNoParams(ID, True);
  1001. end;
  1003. procedure TOleController.SetProperty(const AName: string;
  1004.   const Prop: array of const);
  1005. begin
  1006.   SetPropertyByID(NameToDispID(AName), Prop);
  1007. end;
  1009. function TOleController.GetProperty(const AName: string): PVariant;
  1010. begin
  1011.   Result := GetPropertyByID(NameToDispID(AName));
  1012. end;
  1014. procedure TOleController.CallProcedure(const AName: string;
  1015.   const Params: array of const);
  1016. begin
  1017.   CallProcedureByID(NameToDispID(AName), Params);
  1018. end;
  1020. function TOleController.CallFunction(const AName: string;
  1021.   const Params: array of const): PVariant;
  1022. begin
  1023.   Result := CallFunctionByID(NameToDispID(AName), Params);
  1024. end;
  1026. procedure TOleController.CallProcedureNamedParams(const AName: string;
  1027.   const Params: array of const; const ParamNames: array of string);
  1028. var
  1029.   DispIDs: array[0..MaxDispArgs] of TDispID;
  1030. begin
  1031.   CallProcedureByIDsNamedParams(NameToDispIDs(AName, ParamNames, @DispIDs)^,
  1032.     Params, High(ParamNames) + 1);
  1033. end;
  1035. function TOleController.CallFunctionNamedParams(const AName: string;
  1036.   const Params: array of const; const ParamNames: array of string): PVariant;
  1037. var
  1038.   DispIDs: array[0..MaxDispArgs] of TDispID;
  1039. begin
  1040.   Result := CallFunctionByIDsNamedParams(NameToDispIDs(AName, ParamNames,
  1041.     @DispIDs)^, Params, High(ParamNames) + 1);
  1042. end;
  1044. procedure TOleController.CallProcedureNoParams(const AName: string);
  1045. begin
  1046.   CallProcedureNoParamsByID(NameToDispID(AName));
  1047. end;
  1049. function TOleController.CallFunctionNoParams(const AName: string): PVariant;
  1050. begin
  1051.   Result := CallFunctionNoParamsByID(NameToDispID(AName));
  1052. end;
  1054. procedure TOleController.SetLocale(PrimaryLangID, SubLangID: Word);
  1055. begin
  1056.   FLocale := CreateLCID(PrimaryLangID, SubLangID);
  1057. end;
  1059. { Utility routines }
  1061. function MakeLangID(PrimaryLangID, SubLangID: Word): Word;
  1062. begin
  1063.   Result := (SubLangID shl 10) or PrimaryLangID;
  1064. end;
  1066. function MakeLCID(LangID: Word): TLCID;
  1067. begin
  1068.   Result := TLCID(LangID or (Longint(0) shl 16));
  1069. end;
  1071. function CreateLCID(PrimaryLangID, SubLangID: Word): TLCID;
  1072. begin
  1073.   Result := MakeLCID(MakeLangID(PrimaryLangID, SubLangID));
  1074. end;
  1076. function ExtractLangID(LCID: TLCID): Word;
  1077. begin
  1078.   Result := LCID and $FF;
  1079. end;
  1081. function ExtractSubLangID(LCID: TLCID): Word;
  1082. begin
  1083.   Result := LCID and ($FF shl 10) shr 10;
  1084. end;
  1086. {$IFDEF WIN32}
  1087. initialization
  1088. finalization
  1089.   DoneOLE;
  1090. {$ELSE}
  1091. initialization
  1092.   AddExitProc(DoneOLE);
  1093. {$ENDIF}
  1094. end.