home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1997 August / VPR9708A.ISO / D3TRIAL / INSTALL / DATA.Z / COMOBJ.INT < prev    next >
Text File  |  1997-03-21  |  10KB  |  275 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Runtime Library                          }
  5. {                                                       }
  6. {       Copyright (C) 1997 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ComObj;
  11.  
  12. interface
  13.  
  14. uses Windows, ActiveX, SysUtils;
  15.  
  16. type
  17.  
  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 GetTypeLib: ITypeLib; virtual; abstract;
  33.   public
  34.     property HelpFileName: string;
  35.     property ServerFileName: string;
  36.     property ServerKey: string;
  37.     property ServerName: string;
  38.     property TypeLib: ITypeLib;
  39.   end;
  40.  
  41. { COM class manager }
  42.  
  43.   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  44.  
  45.   TComClassManager = class(TObject)
  46.   public
  47.     procedure ForEachFactory(ComServer: TComServerObject;
  48.       FactoryProc: TFactoryProc);
  49.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  50.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  51.   end;
  52.  
  53. { COM object }
  54.  
  55.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  56.   protected
  57.     { IUnknown }
  58.     function IUnknown.QueryInterface = ObjQueryInterface;
  59.     function IUnknown._AddRef = ObjAddRef;
  60.     function IUnknown._Release = ObjRelease;
  61.     { IUnknown methods for other interfaces }
  62.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  63.     function _AddRef: Integer; stdcall;
  64.     function _Release: Integer; stdcall;
  65.     { ISupportErrorInfo }
  66.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  67.   public
  68.     constructor Create;
  69.     constructor CreateAggregated(const Controller: IUnknown);
  70.     constructor CreateFromFactory(Factory: TComObjectFactory;
  71.       const Controller: IUnknown);
  72.     destructor Destroy; override;
  73.     procedure Initialize; virtual;
  74.     function ObjAddRef: Integer; virtual; stdcall;
  75.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
  76.     function ObjRelease: Integer; virtual; stdcall;
  77.     function SafeCallException(ExceptObject: TObject;
  78.       ExceptAddr: Pointer): HResult; override;
  79.     property Controller: IUnknown;
  80.     property Factory: TComObjectFactory;
  81.     property RefCount: Integer;
  82.   end;
  83.  
  84. { COM class }
  85.  
  86.   TComClass = class of TComObject;
  87.  
  88. { Instancing mode for COM classes }
  89.  
  90.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  91.  
  92. { COM object factory }
  93.  
  94.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  95.   protected
  96.     function GetProgID: string; virtual;
  97.     function GetLicenseString: WideString; virtual;
  98.     function HasMachineLicense: Boolean; virtual;
  99.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  100.     { IUnknown }
  101.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  102.     function _AddRef: Integer; stdcall;
  103.     function _Release: Integer; stdcall;
  104.     { IClassFactory }
  105.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  106.       out Obj): HResult; stdcall;
  107.     function LockServer(fLock: BOOL): HResult; stdcall;
  108.     { IClassFactory2 }
  109.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  110.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  111.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  112.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  113.   public
  114.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  115.       const ClassID: TGUID; const ClassName, Description: string;
  116.       Instancing: TClassInstancing);
  117.     destructor Destroy; override;
  118.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  119.     procedure RegisterClassObject;
  120.     procedure UpdateRegistry(Register: Boolean); virtual;
  121.     property ClassID: TGUID;
  122.     property ClassName: string;
  123.     property ComClass: TClass;
  124.     property ComServer: TComServerObject;
  125.     property Description: string;
  126.     property ErrorIID: TGUID;
  127.     property LicString: WideString;
  128.     property ProgID: string;
  129.     property Instancing: TClassInstancing;
  130.     property ShowErrors: Boolean;
  131.     property SupportsLicensing: Boolean;
  132.   end;
  133.  
  134. { COM object with type information }
  135.  
  136.   TTypedComObject = class(TComObject, IProvideClassInfo)
  137.   protected
  138.     { IProvideClassInfo }
  139.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  140.   end;
  141.  
  142.   TTypedComClass = class of TTypedComObject;
  143.  
  144.   TTypedComObjectFactory = class(TComObjectFactory)
  145.   public
  146.     constructor Create(ComServer: TComServerObject;
  147.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  148.       Instancing: TClassInstancing);
  149.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  150.     procedure UpdateRegistry(Register: Boolean); override;
  151.     property ClassInfo: ITypeInfo;
  152.   end;
  153.  
  154. { OLE Automation object }
  155.  
  156.   TAutoObject = class(TTypedComObject, IDispatch)
  157.   protected
  158.     { IDispatch }
  159.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  160.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  161.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  162.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  163.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  164.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  165.   end;
  166.  
  167. { OLE Automation class }
  168.  
  169.   TAutoClass = class of TAutoObject;
  170.  
  171. { OLE Automation object factory }
  172.  
  173.   TAutoObjectFactory = class(TTypedComObjectFactory)
  174.   public
  175.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  176.       const ClassID: TGUID; Instancing: TClassInstancing);
  177.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  178.     property DispIntfEntry: PInterfaceEntry;
  179.     property DispTypeInfo: ITypeInfo;
  180.   end;
  181.  
  182.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  183.   protected
  184.     { IDispatch }
  185.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  186.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  187.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  188.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  189.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  190.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  191.     { ISupportErrorInfo }
  192.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  193.   public
  194.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  195.     function SafeCallException(ExceptObject: TObject;
  196.       ExceptAddr: Pointer): HResult; override;
  197.     property DispIntfEntry: PInterfaceEntry;
  198.     property DispTypeInfo: ITypeInfo;
  199.     property DispIID: TGUID;
  200.   end;
  201.  
  202. { OLE exception classes }
  203.  
  204.   EOleError = class(Exception);
  205.  
  206.   EOleSysError = class(EOleError)
  207.   public
  208.     constructor Create(const Message: string; ErrorCode: Integer;
  209.       HelpContext: Integer);
  210.     property ErrorCode: Integer;
  211.   end;
  212.  
  213.   EOleException = class(EOleSysError)
  214.   public
  215.     constructor Create(const Message: string; ErrorCode: Integer;
  216.       const Source, HelpFile: string; HelpContext: Integer);
  217.     property HelpFile: string;
  218.     property Source: string;
  219.   end;
  220.  
  221. { Dispatch call descriptor }
  222.  
  223.   PCallDesc = ^TCallDesc;
  224.   TCallDesc = packed record
  225.     CallType: Byte;
  226.     ArgCount: Byte;
  227.     NamedArgCount: Byte;
  228.     ArgTypes: array[0..255] of Byte;
  229.   end;
  230.  
  231.   PDispDesc = ^TDispDesc;
  232.   TDispDesc = packed record
  233.     DispID: Integer;
  234.     ResType: Byte;
  235.     CallDesc: TCallDesc;
  236.   end;
  237.  
  238. var
  239.   ComClassManager: TComClassManager;
  240.  
  241. function CreateComObject(const ClassID: TGUID): IUnknown;
  242. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  243. function CreateOleObject(const ClassName: string): IDispatch;
  244. function GetActiveOleObject(const ClassName: string): IDispatch;
  245.  
  246. procedure OleError(ErrorCode: HResult);
  247. procedure OleCheck(Result: HResult);
  248.  
  249. function StringToGUID(const S: string): TGUID;
  250. function GUIDToString(const ClassID: TGUID): string;
  251.  
  252. function ProgIDToClassID(const ProgID: string): TGUID;
  253. function ClassIDToProgID(const ClassID: TGUID): string;
  254.  
  255. procedure CreateRegKey(const Key, ValueName, Value: string);
  256. procedure DeleteRegKey(const Key: string);
  257.  
  258. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  259.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  260. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  261.  
  262. function HandleSafeCallException(ExceptObject: TObject;
  263.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  264.   HelpFileName: WideString): HResult;
  265.  
  266. function StringToLPOLESTR(const Source: string): POleStr;
  267.  
  268. procedure ReadPropFromBag(PropBag: IPropertyBag; ErrorLog: IErrorLog;
  269.   const Name: string; var Value: Variant);
  270. procedure PutPropInBag(PropBag: IPropertyBag; const Name: string;
  271.   const Value: Variant);
  272. procedure RegisterComServer(const DLLName: string);
  273.  
  274. implementation
  275.