home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Rtl / Sys / COMOBJ.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  63.2 KB  |  2,107 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Runtime Library                  }
  5. {       COM object support                              }
  6. {                                                       }
  7. {       Copyright (C) 1997,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit ComObj;
  12.  
  13. interface
  14.  
  15. uses Windows, ActiveX, SysUtils;
  16.  
  17. type
  18. { Forward declarations }
  19.  
  20.   TComObjectFactory = class;
  21.   {$EXTERNALSYM TComObjectFactory}
  22.  
  23. { COM server abstract base class }
  24.  
  25.   TComServerObject = class(TObject)
  26.   protected
  27.     function CountObject(Created: Boolean): Integer; virtual; abstract;
  28.     function CountFactory(Created: Boolean): Integer; virtual; abstract;
  29.     function GetHelpFileName: string; virtual; abstract;
  30.     function GetServerFileName: string; virtual; abstract;
  31.     function GetServerKey: string; virtual; abstract;
  32.     function GetServerName: string; virtual; abstract;
  33.     function GetStartSuspended: Boolean; virtual; abstract;
  34.     function GetTypeLib: ITypeLib; virtual; abstract;
  35.     procedure SetHelpFileName(const Value: string); virtual; abstract;
  36.   public
  37.     property HelpFileName: string read GetHelpFileName write SetHelpFileName;
  38.     property ServerFileName: string read GetServerFileName;
  39.     property ServerKey: string read GetServerKey;
  40.     property ServerName: string read GetServerName;
  41.     property TypeLib: ITypeLib read GetTypeLib;
  42.     property StartSuspended: Boolean read GetStartSuspended;
  43.   end;
  44.  
  45. { COM class manager }
  46.  
  47.   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  48.   {$EXTERNALSYM TFactoryProc}
  49.  
  50.  
  51.   TComClassManager = class(TObject)
  52.   private
  53.     FFactoryList: TComObjectFactory;
  54.     FLock: TMultiReadExclusiveWriteSynchronizer;
  55.     procedure AddObjectFactory(Factory: TComObjectFactory);
  56.     procedure RemoveObjectFactory(Factory: TComObjectFactory);
  57.   public
  58.     constructor Create;
  59.     destructor Destroy; override;
  60.     procedure ForEachFactory(ComServer: TComServerObject;
  61.       FactoryProc: TFactoryProc);
  62.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  63.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  64.   end;
  65.   {$EXTERNALSYM TComClassManager}
  66.  
  67. { IServerExceptionHandler }
  68. { This interface allows you to report safecall exceptions that occur in a
  69.   TComObject server to a third party, such as an object that logs errors into
  70.   the system event log or a server monitor residing on another machine.
  71.   Obtain an interface from the error logger implementation and assign it
  72.   to your TComObject's ServerExceptionHandler property.  Each TComObject
  73.   instance can have its own server exception handler, or all instances can
  74.   share the same handler.  The server exception handler can override the
  75.   TComObject's default exception handling by setting Handled to True and
  76.   assigning an OLE HResult code to the HResult parameter.
  77. }
  78.  
  79.   IServerExceptionHandler = interface
  80.     ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}']
  81.     procedure OnException(
  82.       const ServerClass, ExceptionClass, ErrorMessage: WideString;
  83.       ExceptAddr: Integer; const ErrorIID, ProgID: WideString;
  84.       var Handled: Integer; var Result: HResult); dispid 2;
  85.   end;
  86.  
  87. { COM object }
  88.  
  89.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  90.   private
  91.     FController: Pointer;
  92.     FFactory: TComObjectFactory;
  93.     FNonCountedObject: Boolean;
  94.     FRefCount: Integer;
  95.     FServerExceptionHandler: IServerExceptionHandler;
  96.     function GetController: IUnknown;
  97.   protected
  98.     { IUnknown }
  99.     function IUnknown.QueryInterface = ObjQueryInterface;
  100.     function IUnknown._AddRef = ObjAddRef;
  101.     function IUnknown._Release = ObjRelease;
  102.     { IUnknown methods for other interfaces }
  103.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  104.     function _AddRef: Integer; stdcall;
  105.     function _Release: Integer; stdcall;
  106.     { ISupportErrorInfo }
  107.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  108.   public
  109.     constructor Create;
  110.     constructor CreateAggregated(const Controller: IUnknown);
  111.     constructor CreateFromFactory(Factory: TComObjectFactory;
  112.       const Controller: IUnknown);
  113.     destructor Destroy; override;
  114.     procedure Initialize; virtual;
  115.     function ObjAddRef: Integer; virtual; stdcall;
  116.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  117.     function ObjRelease: Integer; virtual; stdcall;
  118.     function SafeCallException(ExceptObject: TObject;
  119.       ExceptAddr: Pointer): HResult; override;
  120.     property Controller: IUnknown read GetController;
  121.     property Factory: TComObjectFactory read FFactory;
  122.     property RefCount: Integer read FRefCount;
  123.     property ServerExceptionHandler: IServerExceptionHandler
  124.       read FServerExceptionHandler write FServerExceptionHandler;
  125.   end;
  126.   {$EXTERNALSYM TComObject}
  127.  
  128. { COM class }
  129.  
  130.   TComClass = class of TComObject;
  131.   {$EXTERNALSYM TComClass}
  132.  
  133. { Instancing mode for COM classes }
  134.  
  135.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  136.  
  137. { Threading model supported by COM classes }
  138.  
  139.   TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth);
  140.  
  141. { COM object factory }
  142.  
  143.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  144.   private
  145.     FNext: TComObjectFactory;
  146.     FComServer: TComServerObject;
  147.     FComClass: TClass;
  148.     FClassID: TGUID;
  149.     FClassName: string;
  150.     FDescription: string;
  151.     FErrorIID: TGUID;
  152.     FInstancing: TClassInstancing;
  153.     FLicString: WideString;
  154.     FRegister: Longint;
  155.     FShowErrors: Boolean;
  156.     FSupportsLicensing: Boolean;
  157.     FThreadingModel: TThreadingModel;
  158.   protected
  159.     function GetProgID: string; virtual;
  160.     function GetLicenseString: WideString; virtual;
  161.     function HasMachineLicense: Boolean; virtual;
  162.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  163.     { IUnknown }
  164.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  165.     function _AddRef: Integer; stdcall;
  166.     function _Release: Integer; stdcall;
  167.     { IClassFactory }
  168.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  169.       out Obj): HResult; stdcall;
  170.     function LockServer(fLock: BOOL): HResult; stdcall;
  171.     { IClassFactory2 }
  172.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  173.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  174.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  175.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  176.   public
  177.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  178.       const ClassID: TGUID; const ClassName, Description: string;
  179.       Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
  180.     destructor Destroy; override;
  181.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  182.     procedure RegisterClassObject;
  183.     procedure UpdateRegistry(Register: Boolean); virtual;
  184.     property ClassID: TGUID read FClassID;
  185.     property ClassName: string read FClassName;
  186.     property ComClass: TClass read FComClass;
  187.     property ComServer: TComServerObject read FComServer;
  188.     property Description: string read FDescription;
  189.     property ErrorIID: TGUID read FErrorIID write FErrorIID;
  190.     property LicString: WideString read FLicString write FLicString;
  191.     property ProgID: string read GetProgID;
  192.     property Instancing: TClassInstancing read FInstancing;
  193.     property ShowErrors: Boolean read FShowErrors write FShowErrors;
  194.     property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing;
  195.     property ThreadingModel: TThreadingModel read FThreadingModel;
  196.   end;
  197.   {$EXTERNALSYM TComObjectFactory}
  198.  
  199. { COM objects intended to be aggregated / contained }
  200.  
  201.   TAggregatedObject = class
  202.   private
  203.     FController: Pointer;
  204.     function GetController: IUnknown;
  205.   protected
  206.     { IUnknown }
  207.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  208.     function _AddRef: Integer; stdcall;
  209.     function _Release: Integer; stdcall;
  210.   public
  211.     constructor Create(Controller: IUnknown);
  212.     property Controller: IUnknown read GetController;
  213.   end;
  214.  
  215.   TContainedObject = class(TAggregatedObject, IUnknown)
  216.   protected
  217.     { IUnknown }
  218.     function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  219.   end;
  220.  
  221. { COM object with type information }
  222.  
  223.   TTypedComObject = class(TComObject, IProvideClassInfo)
  224.   protected
  225.     { IProvideClassInfo }
  226.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  227.   end;
  228.   {$EXTERNALSYM TTypedComObject}
  229.  
  230.   TTypedComClass = class of TTypedComObject;
  231.   {$EXTERNALSYM TTypedComClass}
  232.  
  233.   TTypedComObjectFactory = class(TComObjectFactory)
  234.   private
  235.     FClassInfo: ITypeInfo;
  236.   public
  237.     constructor Create(ComServer: TComServerObject;
  238.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  239.       Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
  240.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  241.     procedure UpdateRegistry(Register: Boolean); override;
  242.     property ClassInfo: ITypeInfo read FClassInfo;
  243.   end;
  244.   {$EXTERNALSYM TTypedComObjectFactory}
  245.  
  246. { OLE Automation object }
  247.  
  248.   TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object;
  249.   {$EXTERNALSYM TConnectEvent}
  250.  
  251.   TAutoObjectFactory = class;
  252.   {$EXTERNALSYM TAutoObjectFactory}
  253.  
  254.   TAutoObject = class(TTypedComObject, IDispatch)
  255.   private
  256.     FEventSink: IUnknown;
  257.     FAutoFactory: TAutoObjectFactory;
  258.   protected
  259.     { IDispatch }
  260.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  261.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  262.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  263.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  264.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  265.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  266.     { Other methods }
  267.     procedure EventConnect(const Sink: IUnknown; Connecting: Boolean);
  268.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  269.     property AutoFactory: TAutoObjectFactory read FAutoFactory;
  270.     property EventSink: IUnknown read FEventSink write FEventSink;
  271.   public
  272.     procedure Initialize; override;
  273.   end;
  274.   {$EXTERNALSYM TAutoObject}
  275.  
  276. { OLE Automation class }
  277.  
  278.   TAutoClass = class of TAutoObject;
  279.   {$EXTERNALSYM TAutoClass}
  280.  
  281. { OLE Automation object factory }
  282.  
  283.   TAutoObjectFactory = class(TTypedComObjectFactory)
  284.   private
  285.     FDispTypeInfo: ITypeInfo;
  286.     FDispIntfEntry: PInterfaceEntry;
  287.     FEventIID: TGUID;
  288.     FEventTypeInfo: ITypeInfo;
  289.   public
  290.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  291.       const ClassID: TGUID; Instancing: TClassInstancing;
  292.       ThreadingModel: TThreadingModel = tmSingle);
  293.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  294.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  295.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  296.     property EventIID: TGUID read FEventIID;
  297.     property EventTypeInfo: ITypeInfo read FEventTypeInfo;
  298.   end;
  299.  
  300.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  301.   private
  302.     FDispTypeInfo: ITypeInfo;
  303.     FDispIntfEntry: PInterfaceEntry;
  304.     FDispIID: TGUID;
  305.   protected
  306.     { IDispatch }
  307.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  308.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  309.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  310.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  311.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  312.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  313.     { ISupportErrorInfo }
  314.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  315.   public
  316.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  317.     function SafeCallException(ExceptObject: TObject;
  318.       ExceptAddr: Pointer): HResult; override;
  319.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  320.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  321.     property DispIID: TGUID read FDispIID;
  322.   end;
  323.  
  324. { OLE exception classes }
  325.  
  326.   EOleError = class(Exception);
  327.  
  328.   EOleSysError = class(EOleError)
  329.   private
  330.     FErrorCode: HRESULT;
  331.   public
  332.     constructor Create(const Message: string; ErrorCode: HRESULT;
  333.       HelpContext: Integer);
  334.     property ErrorCode: HRESULT read FErrorCode write FErrorCode;
  335.   end;
  336.  
  337.   EOleException = class(EOleSysError)
  338.   private
  339.     FSource: string;
  340.     FHelpFile: string;
  341.   public
  342.     constructor Create(const Message: string; ErrorCode: HRESULT;
  343.       const Source, HelpFile: string; HelpContext: Integer);
  344.     property HelpFile: string read FHelpFile write FHelpFile;
  345.     property Source: string read FSource write FSource;
  346.   end;
  347.  
  348.   EOleRegistrationError = class(EOleError);
  349.  
  350. type
  351.   { Dispatch call descriptor }
  352.  
  353.   PCallDesc = ^TCallDesc;
  354.   TCallDesc = packed record
  355.     CallType: Byte;
  356.     ArgCount: Byte;
  357.     NamedArgCount: Byte;
  358.     ArgTypes: array[0..255] of Byte;
  359.   end;
  360.  
  361.   PDispDesc = ^TDispDesc;
  362.   TDispDesc = packed record
  363.     DispID: Integer;
  364.     ResType: Byte;
  365.     CallDesc: TCallDesc;
  366.   end;
  367.  
  368. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  369.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  370. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  371.  
  372. function HandleSafeCallException(ExceptObject: TObject;
  373.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  374.   HelpFileName: WideString): HResult;
  375.  
  376. function CreateComObject(const ClassID: TGUID): IUnknown;
  377. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  378. function CreateOleObject(const ClassName: string): IDispatch;
  379. function GetActiveOleObject(const ClassName: string): IDispatch;
  380.  
  381. procedure OleError(ErrorCode: HResult);
  382. procedure OleCheck(Result: HResult);
  383.  
  384. function StringToGUID(const S: string): TGUID;
  385. function GUIDToString(const ClassID: TGUID): string;
  386.  
  387. function ProgIDToClassID(const ProgID: string): TGUID;
  388. function ClassIDToProgID(const ClassID: TGUID): string;
  389.  
  390. procedure CreateRegKey(const Key, ValueName, Value: string);
  391. procedure DeleteRegKey(const Key: string);
  392. function GetRegStringValue(const Key, ValueName: string): string;
  393.  
  394. function StringToLPOLESTR(const Source: string): POleStr;
  395.  
  396. procedure RegisterComServer(const DLLName: string);
  397. procedure RegisterAsService(const ClassID, ServiceName: string);
  398.  
  399. function CreateClassID: string;
  400.  
  401. procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  402.   const Sink: IUnknown; var Connection: Longint);
  403. procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  404.   var Connection: Longint);
  405.  
  406. type
  407.   TCoCreateInstanceExProc = function (const clsid: TCLSID;
  408.     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
  409.     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
  410.   {$EXTERNALSYM TCoCreateInstanceExProc}
  411.   TCoInitializeExProc = function (pvReserved: Pointer;
  412.     coInit: Longint): HResult; stdcall;
  413.   {$EXTERNALSYM TCoInitializeExProc}
  414.   TCoAddRefServerProcessProc = function :Longint; stdcall;
  415.   {$EXTERNALSYM TCoAddRefServerProcessProc}
  416.   TCoReleaseServerProcessProc = function :Longint; stdcall;
  417.   {$EXTERNALSYM TCoReleaseServerProcessProc}
  418.   TCoResumeClassObjectsProc = function :HResult; stdcall;
  419.   {$EXTERNALSYM TCoResumeClassObjectsProc}
  420.   TCoSuspendClassObjectsProc = function :HResult; stdcall;
  421.   {$EXTERNALSYM TCoSuspendClassObjectsProc}
  422.  
  423. // COM functions that are only available on DCOM updated OSs
  424. // These pointers may be nil on Win95 or Win NT 3.51 systems
  425. var
  426.   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
  427.   {$EXTERNALSYM CoCreateInstanceEx}
  428.   CoInitializeEx: TCoInitializeExProc = nil;
  429.   {$EXTERNALSYM CoInitializeEx}
  430.   CoAddRefServerProcess: TCoAddRefServerProcessProc = nil;
  431.   {$EXTERNALSYM CoAddRefServerProcess}
  432.   CoReleaseServerProcess: TCoReleaseServerProcessProc = nil;
  433.   {$EXTERNALSYM CoReleaseServerProcess}
  434.   CoResumeClassObjects: TCoResumeClassObjectsProc = nil;
  435.   {$EXTERNALSYM CoResumeClassObjects}
  436.   CoSuspendClassObjects: TCoSuspendClassObjectsProc = nil;
  437.   {$EXTERNALSYM CoSuspendClassObjects}
  438.  
  439.  
  440. { CoInitFlags determines the COM threading model of the application or current
  441.   thread. This bitflag value is passed to CoInitializeEx in ComServ initialization.
  442.   Assign COINIT_APARTMENTTHREADED or COINIT_MULTITHREADED to this variable before
  443.   Application.Initialize is called by the project source file to select a
  444.   threading model.  Other CoInitializeEx flags (such as COINIT_SPEED_OVER_MEMORY)
  445.   can be OR'd in also.  }
  446. var
  447.   CoInitFlags: Integer = -1;  // defaults to no threading model, call CoInitialize()
  448.  
  449. function ComClassManager: TComClassManager;
  450. {$EXTERNALSYM ComClassManager}
  451.  
  452. implementation
  453.  
  454. uses ComConst;
  455.  
  456. var
  457.   OleUninitializing: Boolean;
  458.  
  459. { Handle a safe call exception }
  460.  
  461. function HandleSafeCallException(ExceptObject: TObject;
  462.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  463.   HelpFileName: WideString): HResult;
  464. var
  465.   E: TObject;
  466.   CreateError: ICreateErrorInfo;
  467.   ErrorInfo: IErrorInfo;
  468. begin
  469.   Result := E_UNEXPECTED;
  470.   E := ExceptObject;
  471.   if Succeeded(CreateErrorInfo(CreateError)) then
  472.   begin
  473.     CreateError.SetGUID(ErrorIID);
  474.     if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID));
  475.     if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName));
  476.     if E is Exception then
  477.     begin
  478.       CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
  479.       CreateError.SetHelpContext(Exception(E).HelpContext);
  480.       if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
  481.         Result := EOleSysError(E).ErrorCode;
  482.     end;
  483.     if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
  484.       SetErrorInfo(0, ErrorInfo);
  485.   end;
  486. end;
  487.  
  488. { TDispatchSilencer }
  489.  
  490. type
  491.   TDispatchSilencer = class(TInterfacedObject, IUnknown, IDispatch)
  492.   private
  493.     Dispatch: IDispatch;
  494.     DispIntfIID: TGUID;
  495.   public
  496.     constructor Create(ADispatch: IUnknown; const ADispIntfIID: TGUID);
  497.     { IUnknown }
  498.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  499.     { IDispatch }
  500.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  501.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  502.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  503.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  504.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  505.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  506.   end;
  507.  
  508. constructor TDispatchSilencer.Create(ADispatch: IUnknown;
  509.   const ADispIntfIID: TGUID);
  510. begin
  511.   inherited Create;
  512.   DispIntfIID := ADispIntfIID;
  513.   OleCheck(ADispatch.QueryInterface(ADispIntfIID, Dispatch));
  514. end;
  515.  
  516. function TDispatchSilencer.QueryInterface(const IID: TGUID; out Obj): HResult;
  517. begin
  518.   Result := inherited QueryInterface(IID, Obj);
  519.   if Result = E_NOINTERFACE then
  520.     if IsEqualGUID(IID, DispIntfIID) then
  521.     begin
  522.       IDispatch(Obj) := Self;
  523.       Result := S_OK;
  524.     end
  525.     else
  526.       Result := Dispatch.QueryInterface(IID, Obj);
  527. end;
  528.  
  529. function TDispatchSilencer.GetTypeInfoCount(out Count: Integer): HResult;
  530. begin
  531.   Result := Dispatch.GetTypeInfoCount(Count);
  532. end;
  533.  
  534. function TDispatchSilencer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
  535. begin
  536.   Result := Dispatch.GetTypeInfo(Index, LocaleID, TypeInfo);
  537. end;
  538.  
  539. function TDispatchSilencer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  540.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  541. begin
  542.   Result := Dispatch.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
  543. end;
  544.  
  545. function TDispatchSilencer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  546.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  547. begin
  548.   { Ignore error since some containers, such as Internet Explorer 3.0x, will
  549.     return error when the method was not handled, or scripting errors occur }
  550.   Dispatch.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo,
  551.     ArgErr);
  552.   Result := S_OK;
  553. end;
  554.  
  555. { TComClassManager }
  556. constructor TComClassManager.Create;
  557. begin
  558.   inherited Create;
  559.   FLock := TMultiReadExclusiveWriteSynchronizer.Create;
  560. end;
  561.  
  562. destructor TComClassManager.Destroy;
  563. begin
  564.   FLock.Free;
  565.   inherited Destroy;
  566. end;
  567.  
  568. procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory);
  569. begin
  570.   FLock.BeginWrite;
  571.   try
  572.     Factory.FNext := FFactoryList;
  573.     FFactoryList := Factory;
  574.   finally
  575.     FLock.EndWrite;
  576.   end;
  577. end;
  578.  
  579. procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
  580.   FactoryProc: TFactoryProc);
  581. var
  582.   Factory, Next: TComObjectFactory;
  583. begin
  584.   FLock.BeginWrite;  // FactoryProc could add or delete factories from list
  585.   try
  586.     Factory := FFactoryList;
  587.     while Factory <> nil do
  588.     begin
  589.       Next := Factory.FNext;
  590.       if Factory.ComServer = ComServer then FactoryProc(Factory);
  591.       Factory := Next;
  592.     end;
  593.   finally
  594.     FLock.EndWrite;
  595.   end;
  596. end;
  597.  
  598. function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  599. begin
  600.   FLock.BeginRead;
  601.   try
  602.     Result := FFactoryList;
  603.     while Result <> nil do
  604.     begin
  605.       if Result.ComClass = ComClass then Exit;
  606.       Result := Result.FNext;
  607.     end;
  608.     raise EOleError.CreateResFmt(@SObjectFactoryMissing, [ComClass.ClassName]);
  609.   finally
  610.     FLock.EndRead;
  611.   end;
  612. end;
  613.  
  614. function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  615. begin
  616.   FLock.BeginRead;
  617.   try
  618.     Result := FFactoryList;
  619.     while Result <> nil do
  620.     begin
  621.       if IsEqualGUID(Result.ClassID, ClassID) then Exit;
  622.       Result := Result.FNext;
  623.     end;
  624.   finally
  625.     FLock.EndRead;
  626.   end;
  627. end;
  628.  
  629. procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory);
  630. var
  631.   F, P: TComObjectFactory;
  632. begin
  633.   FLock.BeginWrite;
  634.   try
  635.     P := nil;
  636.     F := FFactoryList;
  637.     while F <> nil do
  638.     begin
  639.       if F = Factory then
  640.       begin
  641.         if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext;
  642.         Exit;
  643.       end;
  644.       P := F;
  645.       F := F.FNext;
  646.     end;
  647.   finally
  648.     FLock.EndWrite;
  649.   end;
  650. end;
  651.  
  652. { TComObject }
  653.  
  654. constructor TComObject.Create;
  655. begin
  656.   FNonCountedObject := True;
  657.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil);
  658. end;
  659.  
  660. constructor TComObject.CreateAggregated(const Controller: IUnknown);
  661. begin
  662.   FNonCountedObject := True;
  663.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller);
  664. end;
  665.  
  666. constructor TComObject.CreateFromFactory(Factory: TComObjectFactory;
  667.   const Controller: IUnknown);
  668. begin
  669.   FRefCount := 1;
  670.   FFactory := Factory;
  671.   FController := Pointer(Controller);
  672.   if not FNonCountedObject then FFactory.ComServer.CountObject(True);
  673.   Initialize;
  674.   Dec(FRefCount);
  675. end;
  676.  
  677. destructor TComObject.Destroy;
  678. begin
  679.   if not OleUninitializing then
  680.   begin
  681.     if (FFactory <> nil) and not FNonCountedObject then
  682.       FFactory.ComServer.CountObject(False);
  683.     if FRefCount > 0 then CoDisconnectObject(Self, 0);
  684.   end;
  685. end;
  686.  
  687. function TComObject.GetController: IUnknown;
  688. begin
  689.   Result := IUnknown(FController);
  690. end;
  691.  
  692. procedure TComObject.Initialize;
  693. begin
  694. end;
  695.  
  696. function TComObject.SafeCallException(ExceptObject: TObject;
  697.   ExceptAddr: Pointer): HResult;
  698. var
  699.   Msg: string;
  700.   Handled: Integer;
  701. begin
  702.   Handled := 0;
  703.   if ServerExceptionHandler <> nil then
  704.   begin
  705.     if ExceptObject is Exception then
  706.       Msg := Exception(ExceptObject).Message;
  707.     Result := 0;
  708.     ServerExceptionHandler.OnException(ClassName,
  709.       ExceptObject.ClassName, Msg, Integer(ExceptAddr),
  710.       WideString(GUIDToString(FFactory.ErrorIID)),
  711.       FFactory.ProgID, Handled, Result);
  712.   end;
  713.   if Handled = 0 then
  714.     Result := HandleSafeCallException(ExceptObject, ExceptAddr,
  715.       FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);
  716. end;
  717.  
  718. { TComObject.IUnknown }
  719.  
  720. function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
  721. begin
  722.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  723. end;
  724.  
  725. function TComObject.ObjAddRef: Integer;
  726. begin
  727.   Result := InterlockedIncrement(FRefCount);
  728. end;
  729.  
  730. function TComObject.ObjRelease: Integer;
  731. begin
  732.   // InterlockedDecrement returns only 0 or 1 on Win95 and NT 3.51
  733.   // returns actual result on NT 4.0
  734.   Result := InterlockedDecrement(FRefCount);
  735.   if Result = 0 then Destroy;
  736. end;
  737.  
  738. { TComObject.IUnknown for other interfaces }
  739.  
  740. function TComObject.QueryInterface(const IID: TGUID; out Obj): HResult;
  741. begin
  742.   if FController <> nil then
  743.     Result := IUnknown(FController).QueryInterface(IID, Obj) else
  744.     Result := ObjQueryInterface(IID, Obj);
  745. end;
  746.  
  747. function TComObject._AddRef: Integer;
  748. begin
  749.   if FController <> nil then
  750.     Result := IUnknown(FController)._AddRef else
  751.     Result := ObjAddRef;
  752. end;
  753.  
  754. function TComObject._Release: Integer;
  755. begin
  756.   if FController <> nil then
  757.     Result := IUnknown(FController)._Release else
  758.     Result := ObjRelease;
  759. end;
  760.  
  761. { TComObject.ISupportErrorInfo }
  762.  
  763. function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  764. begin
  765.   if GetInterfaceEntry(iid) <> nil then
  766.     Result := S_OK else
  767.     Result := S_FALSE;
  768. end;
  769.  
  770. { TComObjectFactory }
  771.  
  772. constructor TComObjectFactory.Create(ComServer: TComServerObject;
  773.   ComClass: TComClass; const ClassID: TGUID; const ClassName,
  774.   Description: string; Instancing: TClassInstancing;
  775.   ThreadingModel: TThreadingModel);
  776. begin
  777.   IsMultiThread := IsMultiThread or (ThreadingModel <> tmSingle);
  778.   if ThreadingModel in [tmFree, tmBoth] then
  779.     CoInitFlags := COINIT_MULTITHREADED else
  780.   if (ThreadingModel = tmApartment) and (CoInitFlags <> COINIT_MULTITHREADED) then
  781.     CoInitFlags := COINIT_APARTMENTTHREADED;
  782.   ComClassManager.AddObjectFactory(Self);
  783.   FComServer := ComServer;
  784.   FComClass := ComClass;
  785.   FClassID := ClassID;
  786.   FClassName := ClassName;
  787.   FDescription := Description;
  788.   FInstancing := Instancing;
  789.   FErrorIID := IUnknown;
  790.   FShowErrors := True;
  791.   FThreadingModel := ThreadingModel;
  792.   FRegister := -1;
  793. end;
  794.  
  795. destructor TComObjectFactory.Destroy;
  796. begin
  797.   if FRegister <> -1 then CoRevokeClassObject(FRegister);
  798.   ComClassManager.RemoveObjectFactory(Self);
  799. end;
  800.  
  801. function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
  802. begin
  803.   Result := TComClass(FComClass).CreateFromFactory(Self, Controller);
  804. end;
  805.  
  806. function TComObjectFactory.GetProgID: string;
  807. begin
  808.   if FClassName <> '' then
  809.     Result := FComServer.ServerName + '.' + FClassName else
  810.     Result := '';
  811. end;
  812.  
  813. procedure TComObjectFactory.RegisterClassObject;
  814. const
  815.   RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = (
  816.     REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
  817.   SuspendedFlag: array[Boolean] of Integer = (0, REGCLS_SUSPENDED);
  818. begin
  819.   if FInstancing <> ciInternal then
  820.     OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
  821.       RegFlags[FInstancing] or SuspendedFlag[FComServer.StartSuspended], FRegister));
  822. end;
  823.  
  824. procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
  825. const
  826.   ThreadStrs: array[TThreadingModel] of string =
  827.     ('', 'Apartment', 'Free', 'Both');
  828. var
  829.   ClassID, ProgID, ServerKeyName, ShortFileName: string;
  830. begin
  831.   if FInstancing = ciInternal then Exit;
  832.   ClassID := GUIDToString(FClassID);
  833.   ProgID := GetProgID;
  834.   ServerKeyName := 'CLSID\' + ClassID + '\' + FComServer.ServerKey;
  835.   if Register then
  836.   begin
  837.     CreateRegKey('CLSID\' + ClassID, '', Description);
  838.     ShortFileName := FComServer.ServerFileName;
  839.     if AnsiPos(' ', ShortFileName) <> 0 then
  840.       ShortFileName := ExtractShortPathName(ShortFileName);
  841.     CreateRegKey(ServerKeyName, '', ShortFileName);
  842.     if (FThreadingModel <> tmSingle) and IsLibrary then
  843.       CreateRegKey(ServerKeyName, 'ThreadingModel', ThreadStrs[FThreadingModel]);
  844.     if ProgID <> '' then
  845.     begin
  846.       CreateRegKey(ProgID, '', Description);
  847.       CreateRegKey(ProgID + '\Clsid', '', ClassID);
  848.       CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID);
  849.     end;
  850.   end else
  851.   begin
  852.     if ProgID <> '' then
  853.     begin
  854.       DeleteRegKey('CLSID\' + ClassID + '\ProgID');
  855.       DeleteRegKey(ProgID + '\Clsid');
  856.       DeleteRegKey(ProgID);
  857.     end;
  858.     DeleteRegKey(ServerKeyName);
  859.     DeleteRegKey('CLSID\' + ClassID);
  860.   end;
  861. end;
  862.  
  863. function TComObjectFactory.GetLicenseString: WideString;
  864. begin
  865.   if FSupportsLicensing then Result := FLicString
  866.   else Result := '';
  867. end;
  868.  
  869. function TComObjectFactory.HasMachineLicense: Boolean;
  870. begin
  871.   Result := True;
  872. end;
  873.  
  874. function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean;
  875. begin
  876.   Result := AnsiCompareText(LicStr, FLicString) = 0;
  877. end;
  878.  
  879. { TComObjectFactory.IUnknown }
  880.  
  881. function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): HResult;
  882. begin
  883.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  884. end;
  885.  
  886. function TComObjectFactory._AddRef: Integer;
  887. begin
  888.   Result := ComServer.CountFactory(True);
  889. end;
  890.  
  891. function TComObjectFactory._Release: Integer;
  892. begin
  893.   Result := ComServer.CountFactory(False);
  894. end;
  895.  
  896. { TComObjectFactory.IClassFactory }
  897.  
  898. function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
  899.   const IID: TGUID; out Obj): HResult;
  900. begin
  901.   Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj);
  902. end;
  903.  
  904. function TComObjectFactory.LockServer(fLock: BOOL): HResult;
  905. begin
  906.   Result := CoLockObjectExternal(Self, fLock, True);
  907.   // Keep com server alive until this class factory is unlocked
  908.   ComServer.CountObject(fLock);
  909. end;
  910.  
  911. { TComObjectFactory.IClassFactory2 }
  912.  
  913. function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult;
  914. begin
  915.   Result := S_OK;
  916.   try
  917.     with licInfo do
  918.     begin
  919.       cbLicInfo := SizeOf(licInfo);
  920.       fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> '');
  921.       fLicVerified := (not FSupportsLicensing) or HasMachineLicense;
  922.     end;
  923.   except
  924.     Result := E_UNEXPECTED;
  925.   end;
  926. end;
  927.  
  928. function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult;
  929. begin
  930.   // Can't give away a license key on an unlicensed machine
  931.   if not HasMachineLicense then
  932.   begin
  933.     Result := CLASS_E_NOTLICENSED;
  934.     Exit;
  935.   end;
  936.   bstrKey := FLicString;
  937.   Result := NOERROR;
  938. end;
  939.  
  940. function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown;
  941.   const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString;
  942.   out vObject): HResult; stdcall;
  943. var
  944.   ComObject: TComObject;
  945. begin
  946.   // We can't write to a nil pointer.  Duh.
  947.   if @vObject = nil then
  948.   begin
  949.     Result := E_POINTER;
  950.     Exit;
  951.   end;
  952.   // In case of failure, make sure we return at least a nil interface.
  953.   Pointer(vObject) := nil;
  954.   // Check for licensing.
  955.   if FSupportsLicensing and
  956.     ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or
  957.     ((bstrKey = '') and (not HasMachineLicense)) then
  958.   begin
  959.     Result := CLASS_E_NOTLICENSED;
  960.     Exit;
  961.   end;
  962.   // We can only aggregate if they are requesting our IUnknown.
  963.   if (unkOuter <> nil) and not (IsEqualIID(iid, IUnknown)) then
  964.   begin
  965.     Result := CLASS_E_NOAGGREGATION;
  966.     Exit;
  967.   end;
  968.   try
  969.     ComObject := CreateComObject(UnkOuter);
  970.   except
  971.     if FShowErrors and (ExceptObject is Exception) then
  972.       with Exception(ExceptObject) do
  973.       begin
  974.         if (Message <> '') and (AnsiLastChar(Message) > '.') then
  975.           Message := Message + '.';
  976.         MessageBox(0, PChar(Message), PChar(SDAXError), MB_OK or MB_ICONSTOP or
  977.           MB_SETFOREGROUND);
  978.       end;
  979.     Result := E_UNEXPECTED;
  980.     Exit;
  981.   end;
  982.   Result := ComObject.ObjQueryInterface(IID, vObject);
  983.   if ComObject.RefCount = 0 then ComObject.Free;
  984. end;
  985.  
  986. { TAggregatedObject }
  987.  
  988. constructor TAggregatedObject.Create(Controller: IUnknown);
  989. begin
  990.   FController := Pointer(Controller);
  991. end;
  992.  
  993. function TAggregatedObject.GetController: IUnknown;
  994. begin
  995.   Result := IUnknown(FController);
  996. end;
  997.  
  998. { TAggregatedObject.IUnknown }
  999.  
  1000. function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
  1001. begin
  1002.   Result := IUnknown(FController).QueryInterface(IID, Obj);
  1003. end;
  1004.  
  1005. function TAggregatedObject._AddRef: Integer;
  1006. begin
  1007.   Result := IUnknown(FController)._AddRef;
  1008. end;
  1009.  
  1010. function TAggregatedObject._Release: Integer; stdcall;
  1011. begin
  1012.   Result := IUnknown(FController)._Release;
  1013. end;
  1014.  
  1015. { TContainedObject.IUnknown }
  1016.  
  1017. function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
  1018. begin
  1019.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1020. end;
  1021.  
  1022. { TTypedComObject.IProvideClassInfo }
  1023.  
  1024. function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
  1025. begin
  1026.   TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo;
  1027.   Result := S_OK;
  1028. end;
  1029.  
  1030. { TTypedComObjectFactory }
  1031.  
  1032. constructor TTypedComObjectFactory.Create(ComServer: TComServerObject;
  1033.   TypedComClass: TTypedComClass; const ClassID: TGUID;
  1034.   Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
  1035. var
  1036.   ClassName, Description: WideString;
  1037. begin
  1038.   if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then
  1039.     raise EOleError.CreateResFmt(@STypeInfoMissing, [TypedComClass.ClassName]);
  1040.   OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName,
  1041.     @Description, nil, nil));
  1042.   inherited Create(ComServer, TypedComClass, ClassID,
  1043.     ClassName, Description, Instancing, ThreadingModel);
  1044. end;
  1045.  
  1046. function TTypedComObjectFactory.GetInterfaceTypeInfo(
  1047.   TypeFlags: Integer): ITypeInfo;
  1048. const
  1049.   FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE;
  1050. var
  1051.   ClassAttr: PTypeAttr;
  1052.   I, TypeInfoCount, Flags: Integer;
  1053.   RefType: HRefType;
  1054. begin
  1055.   OleCheck(FClassInfo.GetTypeAttr(ClassAttr));
  1056.   TypeInfoCount := ClassAttr^.cImplTypes;
  1057.   ClassInfo.ReleaseTypeAttr(ClassAttr);
  1058.   for I := 0 to TypeInfoCount - 1 do
  1059.   begin
  1060.     OleCheck(ClassInfo.GetImplTypeFlags(I, Flags));
  1061.     if Flags and FlagsMask = TypeFlags then
  1062.     begin
  1063.       OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType));
  1064.       OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
  1065.       Exit;
  1066.     end;
  1067.   end;
  1068.   Result := nil;
  1069. end;
  1070.  
  1071. procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
  1072. var
  1073.   ClassKey: string;
  1074.   TypeLib: ITypeLib;
  1075.   TLibAttr: PTLibAttr;
  1076. begin
  1077.   ClassKey := 'CLSID\' + GUIDToString(FClassID);
  1078.   if Register then
  1079.   begin
  1080.     inherited UpdateRegistry(Register);
  1081.     TypeLib := FComServer.TypeLib;
  1082.     OleCheck(TypeLib.GetLibAttr(TLibAttr));
  1083.     try
  1084.       CreateRegKey(ClassKey + '\Version', '', Format('%d.%d',
  1085.         [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum]));
  1086.       CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid));
  1087.     finally
  1088.       TypeLib.ReleaseTLibAttr(TLibAttr);
  1089.     end;
  1090.   end else
  1091.   begin
  1092.     DeleteRegKey(ClassKey + '\TypeLib');
  1093.     DeleteRegKey(ClassKey + '\Version');
  1094.     inherited UpdateRegistry(Register);
  1095.   end;
  1096. end;
  1097.  
  1098. { TAutoObject }
  1099.  
  1100. procedure TAutoObject.EventConnect(const Sink: IUnknown;
  1101.   Connecting: Boolean);
  1102. begin
  1103.   if Connecting then
  1104.   begin
  1105.     OleCheck(Sink.QueryInterface(FAutoFactory.FEventIID, FEventSink));
  1106.     EventSinkChanged(TDispatchSilencer.Create(Sink, FAutoFactory.FEventIID));
  1107.   end
  1108.   else
  1109.   begin
  1110.     FEventSink := nil;
  1111.     EventSinkChanged(nil);
  1112.   end;
  1113. end;
  1114.  
  1115. procedure TAutoObject.EventSinkChanged(const EventSink: IUnknown);
  1116. begin
  1117. end;
  1118.  
  1119. procedure TAutoObject.Initialize;
  1120. begin
  1121.   FAutoFactory := Factory as TAutoObjectFactory;
  1122.   inherited Initialize;
  1123. end;
  1124.  
  1125. { TAutoObject.IDispatch }
  1126.  
  1127. function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1128.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1129. begin
  1130.   Result := DispGetIDsOfNames(FAutoFactory.DispTypeInfo,
  1131.     Names, NameCount, DispIDs);
  1132. end;
  1133.  
  1134. function TAutoObject.GetTypeInfo(Index, LocaleID: Integer;
  1135.   out TypeInfo): HResult;
  1136. begin
  1137.   Pointer(TypeInfo) := nil;
  1138.   if Index <> 0 then
  1139.   begin
  1140.     Result := DISP_E_BADINDEX;
  1141.     Exit;
  1142.   end;
  1143.   ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo;
  1144.   Result := S_OK;
  1145. end;
  1146.  
  1147. function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
  1148. begin
  1149.   Count := 1;
  1150.   Result := S_OK;
  1151. end;
  1152.  
  1153. function TAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1154.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  1155. const
  1156.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1157. begin
  1158.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1159.   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
  1160.     Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
  1161.     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  1162. end;
  1163.  
  1164. { TAutoObjectFactory }
  1165.  
  1166. constructor TAutoObjectFactory.Create(ComServer: TComServerObject;
  1167.   AutoClass: TAutoClass; const ClassID: TGUID;
  1168.   Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
  1169. var
  1170.   TypeAttr: PTypeAttr;
  1171. begin
  1172.   inherited Create(ComServer, AutoClass, ClassID, Instancing, ThreadingModel);
  1173.   FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
  1174.   if FDispTypeInfo = nil then
  1175.     raise EOleError.CreateResFmt(@SBadTypeInfo, [AutoClass.ClassName]);
  1176.   OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr));
  1177.   FDispIntfEntry := GetIntfEntry(TypeAttr^.guid);
  1178.   FDispTypeInfo.ReleaseTypeAttr(TypeAttr);
  1179.   if FDispIntfEntry = nil then
  1180.     raise EOleError.CreateResFmt(@SDispIntfMissing, [AutoClass.ClassName]);
  1181.   FErrorIID := FDispIntfEntry^.IID;
  1182.   FEventTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT or
  1183.     IMPLTYPEFLAG_FSOURCE);
  1184.   if FEventTypeInfo <> nil then
  1185.   begin
  1186.     OleCheck(FEventTypeInfo.GetTypeAttr(TypeAttr));
  1187.     FEventIID := TypeAttr.guid;
  1188.     FEventTypeInfo.ReleaseTypeAttr(TypeAttr);
  1189.   end;
  1190. end;
  1191.  
  1192. function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
  1193. begin
  1194.   Result := FComClass.GetInterfaceEntry(Guid);
  1195. end;
  1196.  
  1197. { TAutoIntfObject }
  1198.  
  1199. constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  1200. begin
  1201.   inherited Create;
  1202.   OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo));
  1203.   FDispIntfEntry := GetInterfaceEntry(DispIntf);
  1204. end;
  1205.  
  1206. { TAutoIntfObject.IDispatch }
  1207.  
  1208. function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1209.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1210. begin
  1211.   Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs);
  1212. end;
  1213.  
  1214. function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer;
  1215.   out TypeInfo): HResult;
  1216. begin
  1217.   Pointer(TypeInfo) := nil;
  1218.   if Index <> 0 then
  1219.   begin
  1220.     Result := DISP_E_BADINDEX;
  1221.     Exit;
  1222.   end;
  1223.   ITypeInfo(TypeInfo) := FDispTypeInfo;
  1224.   Result := S_OK;
  1225. end;
  1226.  
  1227. function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult;
  1228. begin
  1229.   Count := 1;
  1230.   Result := S_OK;
  1231. end;
  1232.  
  1233. function TAutoIntfObject.Invoke(DispID: Integer; const IID: TGUID;
  1234.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  1235.   ArgErr: Pointer): HResult;
  1236. const
  1237.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1238. begin
  1239.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1240.   Result := FDispTypeInfo.Invoke(Pointer(Integer(Self) +
  1241.     FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult,
  1242.     ExcepInfo, ArgErr);
  1243. end;
  1244.  
  1245. function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  1246. begin
  1247.   if IsEqualGUID(DispIID, iid) then
  1248.     Result := S_OK else
  1249.     Result := S_FALSE;
  1250. end;
  1251.  
  1252. function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
  1253.   ExceptAddr: Pointer): HResult;
  1254. begin
  1255.   Result := HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', '');
  1256. end;
  1257.  
  1258. const
  1259. { Maximum number of dispatch arguments }
  1260.  
  1261.   MaxDispArgs = 64; {!!!}
  1262.  
  1263. { Special variant type codes }
  1264.  
  1265.   varStrArg = $0048;
  1266.  
  1267. { Parameter type masks }
  1268.  
  1269.   atVarMask  = $3F;
  1270.   atTypeMask = $7F;
  1271.   atByRef    = $80;
  1272.  
  1273. function TrimPunctuation(const S: string): string;
  1274. var
  1275.   P: PChar;
  1276. begin
  1277.   Result := S;
  1278.   P := AnsiLastChar(Result);
  1279.   while (Length(Result) > 0) and (P^ in [#0..#32, '.']) do
  1280.   begin
  1281.     SetLength(Result, P - PChar(Result));
  1282.     P := AnsiLastChar(Result);
  1283.   end;
  1284. end;
  1285.  
  1286. { EOleSysError }
  1287.  
  1288. constructor EOleSysError.Create(const Message: string;
  1289.   ErrorCode: HRESULT; HelpContext: Integer);
  1290. var
  1291.   S: string;
  1292. begin
  1293.   S := Message;
  1294.   if S = '' then
  1295.   begin
  1296.     S := SysErrorMessage(ErrorCode);
  1297.     if S = '' then FmtStr(S, SOleError, [ErrorCode]);
  1298.   end;
  1299.   inherited CreateHelp(S, HelpContext);
  1300.   FErrorCode := ErrorCode;
  1301. end;
  1302.  
  1303. { EOleException }
  1304.  
  1305. constructor EOleException.Create(const Message: string; ErrorCode: HRESULT;
  1306.   const Source, HelpFile: string; HelpContext: Integer);
  1307. begin
  1308.   inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext);
  1309.   FSource := Source;
  1310.   FHelpFile := HelpFile;
  1311. end;
  1312.  
  1313.  
  1314. { Raise EOleSysError exception from an error code }
  1315.  
  1316. procedure OleError(ErrorCode: HResult);
  1317. begin
  1318.   raise EOleSysError.Create('', ErrorCode, 0);
  1319. end;
  1320.  
  1321. { Raise EOleSysError exception if result code indicates an error }
  1322.  
  1323. procedure OleCheck(Result: HResult);
  1324. begin
  1325.   if not Succeeded(Result) then OleError(Result);
  1326. end;
  1327.  
  1328. { Convert a string to a GUID }
  1329.  
  1330. function StringToGUID(const S: string): TGUID;
  1331. begin
  1332.   OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
  1333. end;
  1334.  
  1335. { Convert a GUID to a string }
  1336.  
  1337. function GUIDToString(const ClassID: TGUID): string;
  1338. var
  1339.   P: PWideChar;
  1340. begin
  1341.   OleCheck(StringFromCLSID(ClassID, P));
  1342.   Result := P;
  1343.   CoTaskMemFree(P);
  1344. end;
  1345.  
  1346. { Convert a programmatic ID to a class ID }
  1347.  
  1348. function ProgIDToClassID(const ProgID: string): TGUID;
  1349. begin
  1350.   OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
  1351. end;
  1352.  
  1353. { Convert a class ID to a programmatic ID }
  1354.  
  1355. function ClassIDToProgID(const ClassID: TGUID): string;
  1356. var
  1357.   P: PWideChar;
  1358. begin
  1359.   OleCheck(ProgIDFromCLSID(ClassID, P));
  1360.   Result := P;
  1361.   CoTaskMemFree(P);
  1362. end;
  1363.  
  1364. { Create registry key }
  1365.  
  1366. procedure CreateRegKey(const Key, ValueName, Value: string);
  1367. var
  1368.   Handle: HKey;
  1369.   Status, Disposition: Integer;
  1370. begin
  1371.   Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PChar(Key), 0, '',
  1372.     REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
  1373.     @Disposition);
  1374.   if Status = 0 then
  1375.   begin
  1376.     Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_SZ,
  1377.       PChar(Value), Length(Value) + 1);
  1378.     RegCloseKey(Handle);
  1379.   end;
  1380.   if Status <> 0 then raise EOleRegistrationError.CreateRes(@SCreateRegKeyError);
  1381. end;
  1382.  
  1383. { Delete registry key }
  1384.  
  1385. procedure DeleteRegKey(const Key: string);
  1386. begin
  1387.   RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
  1388. end;
  1389.  
  1390. { Get registry value }
  1391.  
  1392. function GetRegStringValue(const Key, ValueName: string): string;
  1393. var
  1394.   Size: DWord;
  1395.   RegKey: HKEY;
  1396. begin
  1397.   Result := '';
  1398.   if RegOpenKey(HKEY_CLASSES_ROOT, PChar(Key), RegKey) = ERROR_SUCCESS then
  1399.   try
  1400.     Size := 256;
  1401.     SetLength(Result, Size);
  1402.     if RegQueryValueEx(RegKey, PChar(ValueName), nil, nil, PByte(PChar(Result)), @Size) = ERROR_SUCCESS then
  1403.       SetLength(Result, Size - 1) else
  1404.       Result := '';
  1405.   finally
  1406.     RegCloseKey(RegKey);
  1407.   end;
  1408. end;
  1409.  
  1410. function CreateComObject(const ClassID: TGUID): IUnknown;
  1411. begin
  1412.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  1413.     CLSCTX_LOCAL_SERVER, IUnknown, Result));
  1414. end;
  1415.  
  1416. function CreateRemoteComObject(const MachineName: WideString;
  1417.   const ClassID: TGUID): IUnknown;
  1418. const
  1419.   LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
  1420.   RemoteFlags = CLSCTX_REMOTE_SERVER;
  1421. var
  1422.   MQI: TMultiQI;
  1423.   ServerInfo: TCoServerInfo;
  1424.   IID_IUnknown: TGuid;
  1425.   Flags, Size: DWORD;
  1426.   LocalMachine: array [0..MAX_COMPUTERNAME_LENGTH] of char;
  1427. begin
  1428.   if @CoCreateInstanceEx = nil then
  1429.     raise Exception.CreateRes(@SDCOMNotInstalled);
  1430.   FillChar(ServerInfo, sizeof(ServerInfo), 0);
  1431.   ServerInfo.pwszName := PWideChar(MachineName);
  1432.   IID_IUnknown := IUnknown;
  1433.   MQI.IID := @IID_IUnknown;
  1434.   MQI.itf := nil;
  1435.   MQI.hr := 0;
  1436.   { If a MachineName is specified check to see if it the local machine.
  1437.     If it isn't, do not allow LocalServers to be used. }
  1438.   if Length(MachineName) > 0 then
  1439.   begin
  1440.     Size := Sizeof(LocalMachine);  // Win95 is hypersensitive to size
  1441.     if GetComputerName(LocalMachine, Size) and
  1442.        (AnsiCompareText(LocalMachine, MachineName) = 0) then
  1443.       Flags := LocalFlags else
  1444.       Flags := RemoteFlags;
  1445.   end else
  1446.     Flags := LocalFlags;
  1447.   OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @ServerInfo, 1, @MQI));
  1448.   OleCheck(MQI.HR);
  1449.   Result := MQI.itf;
  1450. end;
  1451.  
  1452. function CreateOleObject(const ClassName: string): IDispatch;
  1453. var
  1454.   ClassID: TCLSID;
  1455. begin
  1456.   ClassID := ProgIDToClassID(ClassName);
  1457.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  1458.     CLSCTX_LOCAL_SERVER, IDispatch, Result));
  1459. end;
  1460.  
  1461. function GetActiveOleObject(const ClassName: string): IDispatch;
  1462. var
  1463.   ClassID: TCLSID;
  1464.   Unknown: IUnknown;
  1465. begin
  1466.   ClassID := ProgIDToClassID(ClassName);
  1467.   OleCheck(GetActiveObject(ClassID, nil, Unknown));
  1468.   OleCheck(Unknown.QueryInterface(IDispatch, Result));
  1469. end;
  1470.  
  1471. function StringToLPOLESTR(const Source: string): POleStr;
  1472. var
  1473.   SourceLen: Integer;
  1474.   Buffer: PWideChar;
  1475. begin
  1476.   SourceLen := Length(Source);
  1477.   Buffer  := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar));
  1478.   StringToWideChar( Source, Buffer, SourceLen+1 );
  1479.   Result := POleStr( Buffer );
  1480. end;
  1481.  
  1482. function CreateClassID: string;
  1483. var
  1484.   ClassID: TCLSID;
  1485.   P: PWideChar;
  1486. begin
  1487.   CoCreateGuid(ClassID);
  1488.   StringFromCLSID(ClassID, P);
  1489.   Result := P;
  1490.   CoTaskMemFree(P);
  1491. end;
  1492.  
  1493. procedure RegisterComServer(const DLLName: string);
  1494. type
  1495.   TRegProc = function: HResult; stdcall;
  1496. const
  1497.   RegProcName = 'DllRegisterServer'; { Do not localize }
  1498. var
  1499.   Handle: THandle;
  1500.   RegProc: TRegProc;
  1501. begin
  1502.   Handle := SafeLoadLibrary(DLLName);
  1503.   if Handle <= HINSTANCE_ERROR then
  1504.     raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), DLLName]);
  1505.   try
  1506.     RegProc := GetProcAddress(Handle, RegProcName);
  1507.     if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error;
  1508.   finally
  1509.     FreeLibrary(Handle);
  1510.   end;
  1511. end;
  1512.  
  1513. procedure RegisterAsService(const ClassID, ServiceName: string);
  1514. begin
  1515.   CreateRegKey('AppID\' + ClassID, 'LocalService', ServiceName);
  1516.   CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);
  1517. end;
  1518.  
  1519. { Connect an IConnectionPoint interface }
  1520.  
  1521. procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  1522.   const Sink: IUnknown; var Connection: Longint);
  1523. var
  1524.   CPC: IConnectionPointContainer;
  1525.   CP: IConnectionPoint;
  1526. begin
  1527.   Connection := 0;
  1528.   if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
  1529.     if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
  1530.       CP.Advise(Sink, Connection);
  1531. end;
  1532.  
  1533. { Disconnect an IConnectionPoint interface }
  1534.  
  1535. procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  1536.   var Connection: Longint);
  1537. var
  1538.   CPC: IConnectionPointContainer;
  1539.   CP: IConnectionPoint;
  1540. begin
  1541.   if Connection <> 0 then
  1542.     if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
  1543.       if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
  1544.         if Succeeded(CP.Unadvise(Connection)) then Connection := 0;
  1545. end;
  1546.  
  1547. procedure LoadComExProcs;
  1548. var
  1549.   Ole32: HModule;
  1550. begin
  1551.   Ole32 := GetModuleHandle('ole32.dll');
  1552.   if Ole32 <> 0 then
  1553.   begin
  1554.     @CoCreateInstanceEx := GetProcAddress(Ole32, 'CoCreateInstanceEx');
  1555.     @CoInitializeEx := GetProcAddress(Ole32, 'CoInitializeEx');
  1556.     @CoAddRefServerProcess := GetProcAddress(Ole32, 'CoAddRefServerProcess');
  1557.     @CoReleaseServerProcess := GetProcAddress(Ole32, 'CoReleaseServerProcess');
  1558.     @CoResumeClassObjects := GetProcAddress(Ole32, 'CoResumeClassObjects');
  1559.     @CoSuspendClassObjects := GetProcAddress(Ole32, 'CoSuspendClassObjects');
  1560.   end;
  1561. end;
  1562.  
  1563. procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
  1564. var
  1565.   ErrorInfo: IErrorInfo;
  1566.   Source, Description, HelpFile: WideString;
  1567.   HelpContext: Longint;
  1568. begin
  1569.   HelpContext := 0;
  1570.   if GetErrorInfo(0, ErrorInfo) = S_OK then
  1571.   begin
  1572.     ErrorInfo.GetSource(Source);
  1573.     ErrorInfo.GetDescription(Description);
  1574.     ErrorInfo.GetHelpFile(HelpFile);
  1575.     ErrorInfo.GetHelpContext(HelpContext);
  1576.   end;
  1577.   raise EOleException.Create(Description, ErrorCode, Source,
  1578.     HelpFile, HelpContext) at ErrorAddr;
  1579. end;
  1580.  
  1581. { Call Invoke method on the given IDispatch interface using the given
  1582.   call descriptor, dispatch IDs, parameters, and result }
  1583.  
  1584. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  1585.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  1586. type
  1587.   PVarArg = ^TVarArg;
  1588.   TVarArg = array[0..3] of DWORD;
  1589.   TStringDesc = record
  1590.     BStr: PWideChar;
  1591.     PStr: PString;
  1592.   end;
  1593. var
  1594.   I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
  1595.   VarFlag: Byte;
  1596.   ParamPtr: ^Integer;
  1597.   ArgPtr, VarPtr: PVarArg;
  1598.   DispParams: TDispParams;
  1599.   ExcepInfo: TExcepInfo;
  1600.   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  1601.   Args: array[0..MaxDispArgs - 1] of TVarArg;
  1602. begin
  1603.   StrCount := 0;
  1604.   try
  1605.     ArgCount := CallDesc^.ArgCount;
  1606.     if ArgCount <> 0 then
  1607.     begin
  1608.       ParamPtr := Params;
  1609.       ArgPtr := @Args[ArgCount];
  1610.       I := 0;
  1611.       repeat
  1612.         Dec(Integer(ArgPtr), SizeOf(TVarData));
  1613.         ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
  1614.         VarFlag := CallDesc^.ArgTypes[I] and atByRef;
  1615.         if ArgType = varError then
  1616.         begin
  1617.           ArgPtr^[0] := varError;
  1618.           ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND);
  1619.         end else
  1620.         begin
  1621.           if ArgType = varStrArg then
  1622.           begin
  1623.             with Strings[StrCount] do
  1624.               if VarFlag <> 0 then
  1625.               begin
  1626.                 BStr := StringToOleStr(PString(ParamPtr^)^);
  1627.                 PStr := PString(ParamPtr^);
  1628.                 ArgPtr^[0] := varOleStr or varByRef;
  1629.                 ArgPtr^[2] := Integer(@BStr);
  1630.               end else
  1631.               begin
  1632.                 BStr := StringToOleStr(PString(ParamPtr)^);
  1633.                 PStr := nil;
  1634.                 ArgPtr^[0] := varOleStr;
  1635.                 ArgPtr^[2] := Integer(BStr);
  1636.               end;
  1637.             Inc(StrCount);
  1638.           end else
  1639.           if VarFlag <> 0 then
  1640.           begin
  1641.             if (ArgType = varVariant) and
  1642.               (PVarData(ParamPtr^)^.VType = varString) then
  1643.               VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
  1644.             ArgPtr^[0] := ArgType or varByRef;
  1645.             ArgPtr^[2] := ParamPtr^;
  1646.           end else
  1647.           if ArgType = varVariant then
  1648.           begin
  1649.             if PVarData(ParamPtr)^.VType = varString then
  1650.             begin
  1651.               with Strings[StrCount] do
  1652.               begin
  1653.                 BStr := StringToOleStr(string(PVarData(ParamPtr^)^.VString));
  1654.                 PStr := nil;
  1655.                 ArgPtr^[0] := varOleStr;
  1656.                 ArgPtr^[2] := Integer(BStr);
  1657.               end;
  1658.               Inc(StrCount);
  1659.             end else
  1660.             begin
  1661.               VarPtr := PVarArg(ParamPtr);
  1662.               ArgPtr^[0] := VarPtr^[0];
  1663.               ArgPtr^[1] := VarPtr^[1];
  1664.               ArgPtr^[2] := VarPtr^[2];
  1665.               ArgPtr^[3] := VarPtr^[3];
  1666.               Inc(Integer(ParamPtr), 12);
  1667.             end;
  1668.           end else
  1669.           begin
  1670.             ArgPtr^[0] := ArgType;
  1671.             ArgPtr^[2] := ParamPtr^;
  1672.             if (ArgType >= varDouble) and (ArgType <= varDate) then
  1673.             begin
  1674.               Inc(Integer(ParamPtr), 4);
  1675.               ArgPtr^[3] := ParamPtr^;
  1676.             end;
  1677.           end;
  1678.           Inc(Integer(ParamPtr), 4);
  1679.         end;
  1680.         Inc(I);
  1681.       until I = ArgCount;
  1682.     end;
  1683.     DispParams.rgvarg := @Args;
  1684.     DispParams.rgdispidNamedArgs := @DispIDs[1];
  1685.     DispParams.cArgs := ArgCount;
  1686.     DispParams.cNamedArgs := CallDesc^.NamedArgCount;
  1687.     DispID := DispIDs[0];
  1688.     InvKind := CallDesc^.CallType;
  1689.     if InvKind = DISPATCH_PROPERTYPUT then
  1690.     begin
  1691.       if Args[0][0] and varTypeMask = varDispatch then
  1692.         InvKind := DISPATCH_PROPERTYPUTREF;
  1693.       DispIDs[0] := DISPID_PROPERTYPUT;
  1694.       Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
  1695.       Inc(DispParams.cNamedArgs);
  1696.     end else
  1697.       if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
  1698.         InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  1699.     Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
  1700.       Result, @ExcepInfo, nil);
  1701.     if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
  1702.     J := StrCount;
  1703.     while J <> 0 do
  1704.     begin
  1705.       Dec(J);
  1706.       with Strings[J] do
  1707.         if PStr <> nil then OleStrToStrVar(BStr, PStr^);
  1708.     end;
  1709.   finally
  1710.     K := StrCount;
  1711.     while K <> 0 do
  1712.     begin
  1713.       Dec(K);
  1714.       SysFreeString(Strings[K].BStr);
  1715.     end;
  1716.   end;
  1717. end;
  1718.  
  1719. { Call GetIDsOfNames method on the given IDispatch interface }
  1720.  
  1721. procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PChar;
  1722.   NameCount: Integer; DispIDs: PDispIDList);
  1723.  
  1724.   procedure RaiseNameException;
  1725.   begin
  1726.     raise EOleError.CreateResFmt(@SNoMethod, [Names]);
  1727.   end;
  1728.  
  1729. type
  1730.   PNamesArray = ^TNamesArray;
  1731.   TNamesArray = array[0..0] of PWideChar;
  1732. var
  1733.   N, SrcLen, DestLen: Integer;
  1734.   Src: PChar;
  1735.   Dest: PWideChar;
  1736.   NameRefs: PNamesArray;
  1737.   StackTop: Pointer;
  1738.   Temp: Integer;
  1739. begin
  1740.   Src := Names;
  1741.   N := 0;
  1742.   asm
  1743.     MOV  StackTop, ESP
  1744.     MOV  EAX, NameCount
  1745.     INC  EAX
  1746.     SHL  EAX, 2  // sizeof pointer = 4
  1747.     SUB  ESP, EAX
  1748.     LEA  EAX, NameRefs
  1749.     MOV  [EAX], ESP
  1750.   end;
  1751.   repeat
  1752.     SrcLen := StrLen(Src);
  1753.     DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1;
  1754.     asm
  1755.       MOV  EAX, DestLen
  1756.       ADD  EAX, EAX
  1757.       ADD  EAX, 3      // round up to 4 byte boundary
  1758.       AND  EAX, not 3
  1759.       SUB  ESP, EAX
  1760.       LEA  EAX, Dest
  1761.       MOV  [EAX], ESP
  1762.     end;
  1763.     if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest;
  1764.     MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen);
  1765.     Dest[DestLen-1] := #0;
  1766.     Inc(Src, SrcLen+1);
  1767.     Inc(N);
  1768.   until N = NameCount;
  1769.   Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount,
  1770.     GetThreadLocale, DispIDs);
  1771.   if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp);
  1772.   asm
  1773.     MOV  ESP, StackTop
  1774.   end;
  1775. end;
  1776.  
  1777. { Central call dispatcher }
  1778.  
  1779. procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
  1780.   CallDesc: PCallDesc; Params: Pointer); cdecl;
  1781.  
  1782.   procedure RaiseException;
  1783.   begin
  1784.     raise EOleError.CreateRes(@SVarNotObject);
  1785.   end;
  1786.  
  1787. var
  1788.   Dispatch: Pointer;
  1789.   DispIDs: array[0..MaxDispArgs - 1] of Integer;
  1790. begin
  1791.   if TVarData(Instance).VType = varDispatch then
  1792.     Dispatch := TVarData(Instance).VDispatch
  1793.   else if TVarData(Instance).VType = (varDispatch or varByRef) then
  1794.     Dispatch := Pointer(TVarData(Instance).VPointer^)
  1795.   else RaiseException;
  1796.   GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
  1797.     CallDesc^.NamedArgCount + 1, @DispIDs);
  1798.   if Result <> nil then VarClear(Result^);
  1799.   DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
  1800. end;
  1801.  
  1802. { Raise exception given an OLE return code and TExcepInfo structure }
  1803.  
  1804. procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo;
  1805.   ErrorAddr: Pointer; FinalizeExcepInfo: Boolean);
  1806. var
  1807.   E: Exception;
  1808. begin
  1809.   if Status = Integer(DISP_E_EXCEPTION) then
  1810.   begin
  1811.     with ExcepInfo do
  1812.       E := EOleException.Create(bstrDescription, scode, bstrSource,
  1813.         bstrHelpFile, dwHelpContext);
  1814.     if FinalizeExcepInfo then
  1815.       Finalize(ExcepInfo);
  1816.   end else
  1817.     E := EOleSysError.Create('', Status, 0);
  1818.   if ErrorAddr <> nil then
  1819.     raise E at ErrorAddr
  1820.   else
  1821.     raise E;
  1822. end;
  1823.  
  1824. { Raise exception given an OLE return code and TExcepInfo structure }
  1825.  
  1826. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  1827. begin
  1828.   DispCallError(Status, PExcepInfo(@ExcepInfo)^, nil, False);
  1829. end;
  1830.  
  1831. procedure ClearExcepInfo(var ExcepInfo: TExcepInfo);
  1832. begin
  1833.   FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
  1834. end;
  1835.  
  1836. procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc;
  1837.   DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall;
  1838. type
  1839.   TExcepInfoRec = record  // mock type to avoid auto init and cleanup code
  1840.     wCode: Word;
  1841.     wReserved: Word;
  1842.     bstrSource: PWideChar;
  1843.     bstrDescription: PWideChar;
  1844.     bstrHelpFile: PWideChar;
  1845.     dwHelpContext: Longint;
  1846.     pvReserved: Pointer;
  1847.     pfnDeferredFillIn: Pointer;
  1848.     scode: HResult;
  1849.   end;
  1850. var
  1851.   DispParams: TDispParams;
  1852.   ExcepInfo: TExcepInfoRec;
  1853. asm
  1854.         PUSH    EBX
  1855.         PUSH    ESI
  1856.         PUSH    EDI
  1857.         MOV     EBX,CallDesc
  1858.         XOR     EDX,EDX
  1859.         MOV     EDI,ESP
  1860.         MOVZX   ECX,[EBX].TCallDesc.ArgCount
  1861.         MOV     DispParams.cArgs,ECX
  1862.         TEST    ECX,ECX
  1863.         JE      @@10
  1864.         ADD     EBX,OFFSET TCallDesc.ArgTypes
  1865.         MOV     ESI,Params
  1866. @@1:    MOVZX   EAX,[EBX].Byte
  1867.         TEST    AL,atByRef
  1868.         JNE     @@3
  1869.         CMP     AL,varVariant
  1870.         JE      @@2
  1871.         CMP     AL,varDouble
  1872.         JB      @@4
  1873.         CMP     AL,varDate
  1874.         JA      @@4
  1875.         PUSH    [ESI].Integer[4]
  1876.         PUSH    [ESI].Integer[0]
  1877.         PUSH    EDX
  1878.         PUSH    EAX
  1879.         ADD     ESI,8
  1880.         JMP     @@5
  1881. @@2:    PUSH    [ESI].Integer[12]
  1882.         PUSH    [ESI].Integer[8]
  1883.         PUSH    [ESI].Integer[4]
  1884.         PUSH    [ESI].Integer[0]
  1885.         ADD     ESI,16
  1886.         JMP     @@5
  1887. @@3:    AND     AL,atTypeMask
  1888.         OR      EAX,varByRef
  1889. @@4:    PUSH    EDX
  1890.         PUSH    [ESI].Integer[0]
  1891.         PUSH    EDX
  1892.         PUSH    EAX
  1893.         ADD     ESI,4
  1894. @@5:    INC     EBX
  1895.         DEC     ECX
  1896.         JNE     @@1
  1897.         MOV     EBX,CallDesc
  1898. @@10:   MOV     DispParams.rgvarg,ESP
  1899.         MOVZX   EAX,[EBX].TCallDesc.NamedArgCount
  1900.         MOV     DispParams.cNamedArgs,EAX
  1901.         TEST    EAX,EAX
  1902.         JE      @@12
  1903.         MOV     ESI,NamedArgDispIDs
  1904. @@11:   PUSH    [ESI].Integer[EAX*4-4]
  1905.         DEC     EAX
  1906.         JNE     @@11
  1907. @@12:   MOVZX   ECX,[EBX].TCallDesc.CallType
  1908.         CMP     ECX,DISPATCH_PROPERTYPUT
  1909.         JNE     @@20
  1910.         PUSH    DISPID_PROPERTYPUT
  1911.         INC     DispParams.cNamedArgs
  1912.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch
  1913.         JE      @@13
  1914.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown
  1915.         JNE     @@20
  1916. @@13:   MOV     ECX,DISPATCH_PROPERTYPUTREF
  1917. @@20:   MOV     DispParams.rgdispidNamedArgs,ESP
  1918.         PUSH    EDX                     { ArgErr }
  1919.         LEA     EAX,ExcepInfo
  1920.         PUSH    EAX                     { ExcepInfo }
  1921.         PUSH    ECX
  1922.         PUSH    EDX
  1923.         CALL    ClearExcepInfo
  1924.         POP     EDX
  1925.         POP     ECX
  1926.         PUSH    Result                  { VarResult }
  1927.         LEA     EAX,DispParams
  1928.         PUSH    EAX                     { Params }
  1929.         PUSH    ECX                     { Flags }
  1930.         PUSH    EDX                     { LocaleID }
  1931.         PUSH    OFFSET GUID_NULL        { IID }
  1932.         PUSH    DispID                  { DispID }
  1933.         MOV     EAX,Dispatch
  1934.         PUSH    EAX
  1935.         MOV     EAX,[EAX]
  1936.         CALL    [EAX].Pointer[24]
  1937.         TEST    EAX,EAX
  1938.         JE      @@30
  1939.         LEA     EDX,ExcepInfo
  1940.         MOV     CL, 1
  1941.         PUSH    ECX
  1942.         MOV     ECX,[EBP+4]
  1943.         JMP     DispCallError
  1944. @@30:   MOV     ESP,EDI
  1945.         POP     EDI
  1946.         POP     ESI
  1947.         POP     EBX
  1948. end;
  1949.  
  1950. procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch;
  1951.   DispDesc: PDispDesc; Params: Pointer); cdecl;
  1952. asm
  1953.         PUSH    EBX
  1954.         MOV     EBX,DispDesc
  1955.         XOR     EAX,EAX
  1956.         PUSH    EAX
  1957.         PUSH    EAX
  1958.         PUSH    EAX
  1959.         PUSH    EAX
  1960.         MOV     EAX,ESP
  1961.         PUSH    EAX
  1962.         LEA     EAX,Params
  1963.         PUSH    EAX
  1964.         PUSH    EAX
  1965.         PUSH    [EBX].TDispDesc.DispID
  1966.         LEA     EAX,[EBX].TDispDesc.CallDesc
  1967.         PUSH    EAX
  1968.         PUSH    Dispatch
  1969.         CALL    DispCall
  1970.         MOVZX   EAX,[EBX].TDispDesc.ResType
  1971.         MOV     EBX,Result
  1972.         JMP     @ResultTable.Pointer[EAX*4]
  1973.  
  1974. @ResultTable:
  1975.         DD      @ResEmpty
  1976.         DD      @ResNull
  1977.         DD      @ResSmallint
  1978.         DD      @ResInteger
  1979.         DD      @ResSingle
  1980.         DD      @ResDouble
  1981.         DD      @ResCurrency
  1982.         DD      @ResDate
  1983.         DD      @ResString
  1984.         DD      @ResDispatch
  1985.         DD      @ResError
  1986.         DD      @ResBoolean
  1987.         DD      @ResVariant
  1988.         DD      @ResUnknown
  1989.         DD      @ResDecimal
  1990.         DD      @ResError
  1991.         DD      @ResByte
  1992.  
  1993. @ResSingle:
  1994.         FLD     [ESP+8].Single
  1995.         JMP     @ResDone
  1996.  
  1997. @ResDouble:
  1998. @ResDate:
  1999.         FLD     [ESP+8].Double
  2000.         JMP     @ResDone
  2001.  
  2002. @ResCurrency:
  2003.         FILD    [ESP+8].Currency
  2004.         JMP     @ResDone
  2005.  
  2006. @ResString:
  2007.         MOV     EAX,[EBX]
  2008.         TEST    EAX,EAX
  2009.         JE      @@1
  2010.         PUSH    EAX
  2011.         CALL    SysFreeString
  2012. @@1:    MOV     EAX,[ESP+8]
  2013.         MOV     [EBX],EAX
  2014.         JMP     @ResDone
  2015.  
  2016. @ResDispatch:
  2017. @ResUnknown:
  2018.         MOV     EAX,[EBX]
  2019.         TEST    EAX,EAX
  2020.         JE      @@2
  2021.         PUSH    EAX
  2022.         MOV     EAX,[EAX]
  2023.         CALL    [EAX].Pointer[8]
  2024. @@2:    MOV     EAX,[ESP+8]
  2025.         MOV     [EBX],EAX
  2026.         JMP     @ResDone
  2027.  
  2028. @ResVariant:
  2029.         MOV     EAX,EBX
  2030.         CALL    System.@VarClear
  2031.         MOV     EAX,[ESP]
  2032.         MOV     [EBX],EAX
  2033.         MOV     EAX,[ESP+4]
  2034.         MOV     [EBX+4],EAX
  2035.         MOV     EAX,[ESP+8]
  2036.         MOV     [EBX+8],EAX
  2037.         MOV     EAX,[ESP+12]
  2038.         MOV     [EBX+12],EAX
  2039.         JMP     @ResDone
  2040.  
  2041. @ResSmallint:
  2042. @ResInteger:
  2043. @ResBoolean:
  2044. @ResByte:
  2045.         MOV     EAX,[ESP+8]
  2046.  
  2047. @ResDecimal:
  2048. @ResEmpty:
  2049. @ResNull:
  2050. @ResError:
  2051. @ResDone:
  2052.         ADD     ESP,16
  2053.         POP     EBX
  2054. end;
  2055.  
  2056. var
  2057.   ComClassManagerVar: TObject;
  2058.   SaveInitProc: Pointer;
  2059.   NeedToUninitialize: Boolean;
  2060.  
  2061. function ComClassManager: TComClassManager;
  2062. begin
  2063.   if ComClassManagerVar = nil then
  2064.     ComClassManagerVar := TComClassManager.Create;
  2065.   Result := TComClassManager(ComClassManagerVar);
  2066. end;
  2067.  
  2068. procedure InitComObj;
  2069. begin
  2070.   if SaveInitProc <> nil then TProcedure(SaveInitProc);
  2071.   if (CoInitFlags <> -1) and Assigned(ComObj.CoInitializeEx) then
  2072.   begin
  2073.     NeedToUninitialize := Succeeded(ComObj.CoInitializeEx(nil, CoInitFlags));
  2074.     IsMultiThread := IsMultiThread or
  2075.       ((CoInitFlags and COINIT_APARTMENTTHREADED) <> 0) or
  2076.       (CoInitFlags = COINIT_MULTITHREADED);  // this flag has value zero
  2077.   end
  2078.   else
  2079.     NeedToUninitialize := Succeeded(CoInitialize(nil));
  2080. end;
  2081.  
  2082.  
  2083. initialization
  2084. begin
  2085.   LoadComExProcs;
  2086.   VarDispProc := @VarDispInvoke;
  2087.   DispCallByIDProc := @DispCallByID;
  2088.   SafeCallErrorProc := @SafeCallError;
  2089.   if not IsLibrary then
  2090.   begin
  2091.     SaveInitProc := InitProc;
  2092.     InitProc := @InitComObj;
  2093.   end;
  2094. end;
  2095.  
  2096. finalization
  2097. begin
  2098.   OleUninitializing := True;
  2099.   ComClassManagerVar.Free;
  2100.   SafeCallErrorProc := nil;
  2101.   DispCallByIDProc := nil;
  2102.   VarDispProc := nil;
  2103.   if NeedToUninitialize then CoUninitialize;
  2104. end;
  2105.  
  2106. end.
  2107.