home *** CD-ROM | disk | FTP | other *** search
/ PC World Plus! (NZ) 2001 June / HDC50.iso / Runimage / Delphi50 / Doc / COMOBJ.INT < prev    next >
Encoding:
Text File  |  1999-08-11  |  15.0 KB  |  404 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;
  38.     property ServerFileName: string;
  39.     property ServerKey: string;
  40.     property ServerName: string;
  41.     property TypeLib: ITypeLib;
  42.     property StartSuspended: Boolean;
  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.   public
  53.     constructor Create;
  54.     destructor Destroy; override;
  55.     procedure ForEachFactory(ComServer: TComServerObject;
  56.       FactoryProc: TFactoryProc);
  57.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  58.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  59.   end;
  60.   {$EXTERNALSYM TComClassManager}
  61.  
  62. { IServerExceptionHandler }
  63. { This interface allows you to report safecall exceptions that occur in a
  64.   TComObject server to a third party, such as an object that logs errors into
  65.   the system event log or a server monitor residing on another machine.
  66.   Obtain an interface from the error logger implementation and assign it
  67.   to your TComObject's ServerExceptionHandler property.  Each TComObject
  68.   instance can have its own server exception handler, or all instances can
  69.   share the same handler.  The server exception handler can override the
  70.   TComObject's default exception handling by setting Handled to True and
  71.   assigning an OLE HResult code to the HResult parameter.
  72. }
  73.  
  74.   IServerExceptionHandler = interface
  75.     ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}']
  76.     procedure OnException(
  77.       const ServerClass, ExceptionClass, ErrorMessage: WideString;
  78.       ExceptAddr: Integer; const ErrorIID, ProgID: WideString;
  79.       var Handled: Integer; var Result: HResult); dispid 2;
  80.   end;
  81.  
  82. { COM object }
  83.  
  84.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  85.   protected
  86.     { IUnknown }
  87.     function IUnknown.QueryInterface = ObjQueryInterface;
  88.     function IUnknown._AddRef = ObjAddRef;
  89.     function IUnknown._Release = ObjRelease;
  90.     { IUnknown methods for other interfaces }
  91.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  92.     function _AddRef: Integer; stdcall;
  93.     function _Release: Integer; stdcall;
  94.     { ISupportErrorInfo }
  95.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  96.   public
  97.     constructor Create;
  98.     constructor CreateAggregated(const Controller: IUnknown);
  99.     constructor CreateFromFactory(Factory: TComObjectFactory;
  100.       const Controller: IUnknown);
  101.     destructor Destroy; override;
  102.     procedure Initialize; virtual;
  103.     function ObjAddRef: Integer; virtual; stdcall;
  104.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  105.     function ObjRelease: Integer; virtual; stdcall;
  106.     function SafeCallException(ExceptObject: TObject;
  107.       ExceptAddr: Pointer): HResult; override;
  108.     property Controller: IUnknown;
  109.     property Factory: TComObjectFactory;
  110.     property RefCount: Integer;
  111.     property ServerExceptionHandler: IServerExceptionHandler;
  112.   end;
  113.   {$EXTERNALSYM TComObject}
  114.  
  115. { COM class }
  116.  
  117.   TComClass = class of TComObject;
  118.   {$EXTERNALSYM TComClass}
  119.  
  120. { Instancing mode for COM classes }
  121.  
  122.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  123.  
  124. { Threading model supported by COM classes }
  125.  
  126.   TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth);
  127.  
  128. { COM object factory }
  129.  
  130.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  131.   protected
  132.     function GetProgID: string; virtual;
  133.     function GetLicenseString: WideString; virtual;
  134.     function HasMachineLicense: Boolean; virtual;
  135.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  136.     { IUnknown }
  137.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  138.     function _AddRef: Integer; stdcall;
  139.     function _Release: Integer; stdcall;
  140.     { IClassFactory }
  141.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  142.       out Obj): HResult; stdcall;
  143.     function LockServer(fLock: BOOL): HResult; stdcall;
  144.     { IClassFactory2 }
  145.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  146.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  147.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  148.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  149.   public
  150.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  151.       const ClassID: TGUID; const ClassName, Description: string;
  152.       Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
  153.     destructor Destroy; override;
  154.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  155.     procedure RegisterClassObject;
  156.     procedure UpdateRegistry(Register: Boolean); virtual;
  157.     property ClassID: TGUID;
  158.     property ClassName: string;
  159.     property ComClass: TClass;
  160.     property ComServer: TComServerObject;
  161.     property Description: string;
  162.     property ErrorIID: TGUID;
  163.     property LicString: WideString;
  164.     property ProgID: string;
  165.     property Instancing: TClassInstancing;
  166.     property ShowErrors: Boolean;
  167.     property SupportsLicensing: Boolean;
  168.     property T;
  169.   end;
  170.   {$EXTERNALSYM TComObjectFactory}
  171.  
  172. { COM objects intended to be aggregated / contained }
  173.  
  174.   TAggregatedObject = class
  175.   protected
  176.     { IUnknown }
  177.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  178.     function _AddRef: Integer; stdcall;
  179.     function _Release: Integer; stdcall;
  180.   public
  181.     constructor Create(Controller: IUnknown);
  182.     property Controller: IUnknown;
  183.   end;
  184.  
  185.   TContainedObject = class(TAggregatedObject, IUnknown)
  186.   protected
  187.     { IUnknown }
  188.     function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  189.   end;
  190.  
  191. { COM object with type information }
  192.  
  193.   TTypedComObject = class(TComObject, IProvideClassInfo)
  194.   protected
  195.     { IProvideClassInfo }
  196.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  197.   end;
  198.   {$EXTERNALSYM TTypedComObject}
  199.  
  200.   TTypedComClass = class of TTypedComObject;
  201.   {$EXTERNALSYM TTypedComClass}
  202.  
  203.   TTypedComObjectFactory = class(TComObjectFactory)
  204.   public
  205.     constructor Create(ComServer: TComServerObject;
  206.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  207.       Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
  208.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  209.     procedure UpdateRegistry(Register: Boolean); override;
  210.     property ClassInfo: ITypeInfo;
  211.   end;
  212.   {$EXTERNALSYM TTypedComObjectFactory}
  213.  
  214. { OLE Automation object }
  215.  
  216.   TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object;
  217.   {$EXTERNALSYM TConnectEvent}
  218.  
  219.   TAutoObjectFactory = class;
  220.   {$EXTERNALSYM TAutoObjectFactory}
  221.  
  222.   TAutoObject = class(TTypedComObject, IDispatch)
  223.   protected
  224.     { IDispatch }
  225.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  226.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  227.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  228.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  229.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  230.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  231.     { Other methods }
  232.     procedure EventConnect(const Sink: IUnknown; Connecting: Boolean);
  233.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  234.     property AutoFactory: TAutoObjectFactory;
  235.     property EventSink: IUnknown;
  236.   public
  237.     procedure Initialize; override;
  238.   end;
  239.   {$EXTERNALSYM TAutoObject}
  240.  
  241. { OLE Automation class }
  242.  
  243.   TAutoClass = class of TAutoObject;
  244.   {$EXTERNALSYM TAutoClass}
  245.  
  246. { OLE Automation object factory }
  247.  
  248.   TAutoObjectFactory = class(TTypedComObjectFactory)
  249.   public
  250.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  251.       const ClassID: TGUID; Instancing: TClassInstancing;
  252.       ThreadingModel: TThreadingModel = tmSingle);
  253.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  254.     property DispIntfEntry: PInterfaceEntry;
  255.     property DispTypeInfo: ITypeInfo;
  256.     property EventIID: TGUID;
  257.     property EventTypeInfo: ITypeInfo;
  258.   end;
  259.  
  260.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  261.   protected
  262.     { IDispatch }
  263.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  264.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  265.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  266.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  267.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  268.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  269.     { ISupportErrorInfo }
  270.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  271.   public
  272.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  273.     function SafeCallException(ExceptObject: TObject;
  274.       ExceptAddr: Pointer): HResult; override;
  275.     property DispIntfEntry: PInterfaceEntry;
  276.     property DispTypeInfo: ITypeInfo;
  277.     property DispIID: TGUID;
  278.   end;
  279.  
  280. { OLE exception classes }
  281.  
  282.   EOleError = class(Exception);
  283.  
  284.   EOleSysError = class(EOleError)
  285.   public
  286.     constructor Create(const Message: string; ErrorCode: HRESULT;
  287.       HelpContext: Integer);
  288.     property ErrorCode: HRESULT;
  289.   end;
  290.  
  291.   EOleException = class(EOleSysError)
  292.   public
  293.     constructor Create(const Message: string; ErrorCode: HRESULT;
  294.       const Source, HelpFile: string; HelpContext: Integer);
  295.     property HelpFile: string;
  296.     property Source: string;
  297.   end;
  298.  
  299.   EOleRegistrationError = class(EOleError);
  300.  
  301. type
  302.   { Dispatch call descriptor }
  303.  
  304.   PCallDesc = ^TCallDesc;
  305.   TCallDesc = packed record
  306.     CallType: Byte;
  307.     ArgCount: Byte;
  308.     NamedArgCount: Byte;
  309.     ArgTypes: array[0..255] of Byte;
  310.   end;
  311.  
  312.   PDispDesc = ^TDispDesc;
  313.   TDispDesc = packed record
  314.     DispID: Integer;
  315.     ResType: Byte;
  316.     CallDesc: TCallDesc;
  317.   end;
  318.  
  319. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  320.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  321. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  322.  
  323. function HandleSafeCallException(ExceptObject: TObject;
  324.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  325.   HelpFileName: WideString): HResult;
  326.  
  327. function CreateComObject(const ClassID: TGUID): IUnknown;
  328. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  329. function CreateOleObject(const ClassName: string): IDispatch;
  330. function GetActiveOleObject(const ClassName: string): IDispatch;
  331.  
  332. procedure OleError(ErrorCode: HResult);
  333. procedure OleCheck(Result: HResult);
  334.  
  335. function StringToGUID(const S: string): TGUID;
  336. function GUIDToString(const ClassID: TGUID): string;
  337.  
  338. function ProgIDToClassID(const ProgID: string): TGUID;
  339. function ClassIDToProgID(const ClassID: TGUID): string;
  340.  
  341. procedure CreateRegKey(const Key, ValueName, Value: string);
  342. procedure DeleteRegKey(const Key: string);
  343. function GetRegStringValue(const Key, ValueName: string): string;
  344.  
  345. function StringToLPOLESTR(const Source: string): POleStr;
  346.  
  347. procedure RegisterComServer(const DLLName: string);
  348. procedure RegisterAsService(const ClassID, ServiceName: string);
  349.  
  350. function CreateClassID: string;
  351.  
  352. procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  353.   const Sink: IUnknown; var Connection: Longint);
  354. procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  355.   var Connection: Longint);
  356.  
  357. type
  358.   TCoCreateInstanceExProc = function (const clsid: TCLSID;
  359.     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
  360.     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
  361.   {$EXTERNALSYM TCoCreateInstanceExProc}
  362.   TCoInitializeExProc = function (pvReserved: Pointer;
  363.     coInit: Longint): HResult; stdcall;
  364.   {$EXTERNALSYM TCoInitializeExProc}
  365.   TCoAddRefServerProcessProc = function :Longint; stdcall;
  366.   {$EXTERNALSYM TCoAddRefServerProcessProc}
  367.   TCoReleaseServerProcessProc = function :Longint; stdcall;
  368.   {$EXTERNALSYM TCoReleaseServerProcessProc}
  369.   TCoResumeClassObjectsProc = function :HResult; stdcall;
  370.   {$EXTERNALSYM TCoResumeClassObjectsProc}
  371.   TCoSuspendClassObjectsProc = function :HResult; stdcall;
  372.   {$EXTERNALSYM TCoSuspendClassObjectsProc}
  373.  
  374. // COM functions that are only available on DCOM updated OSs
  375. // These pointers may be nil on Win95 or Win NT 3.51 systems
  376. var
  377.   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
  378.   {$EXTERNALSYM CoCreateInstanceEx}
  379.   CoInitializeEx: TCoInitializeExProc = nil;
  380.   {$EXTERNALSYM CoInitializeEx}
  381.   CoAddRefServerProcess: TCoAddRefServerProcessProc = nil;
  382.   {$EXTERNALSYM CoAddRefServerProcess}
  383.   CoReleaseServerProcess: TCoReleaseServerProcessProc = nil;
  384.   {$EXTERNALSYM CoReleaseServerProcess}
  385.   CoResumeClassObjects: TCoResumeClassObjectsProc = nil;
  386.   {$EXTERNALSYM CoResumeClassObjects}
  387.   CoSuspendClassObjects: TCoSuspendClassObjectsProc = nil;
  388.   {$EXTERNALSYM CoSuspendClassObjects}
  389.  
  390.  
  391. { CoInitFlags determines the COM threading model of the application or current
  392.   thread. This bitflag value is passed to CoInitializeEx in ComServ initialization.
  393.   Assign COINIT_APARTMENTTHREADED or COINIT_MULTITHREADED to this variable before
  394.   Application.Initialize is called by the project source file to select a
  395.   threading model.  Other CoInitializeEx flags (such as COINIT_SPEED_OVER_MEMORY)
  396.   can be OR'd in also.  }
  397. var
  398.   CoInitFlags: Integer = -1;  // defaults to no threading model, call CoInitialize()
  399.  
  400. function ComClassManager: TComClassManager;
  401. {$EXTERNALSYM ComClassManager}
  402.  
  403. implementation
  404.