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