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