home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / RTL / SYS / COMOBJ.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  48.0 KB  |  1,653 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 read GetHelpFileName;
  35.     property ServerFileName: string read GetServerFileName;
  36.     property ServerKey: string read GetServerKey;
  37.     property ServerName: string read GetServerName;
  38.     property TypeLib: ITypeLib read GetTypeLib;
  39.   end;
  40.  
  41. { COM class manager }
  42.  
  43.   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  44.  
  45.   TComClassManager = class(TObject)
  46.   private
  47.     FFactoryList: TComObjectFactory;
  48.     procedure AddObjectFactory(Factory: TComObjectFactory);
  49.     procedure RemoveObjectFactory(Factory: TComObjectFactory);
  50.   public
  51.     procedure ForEachFactory(ComServer: TComServerObject;
  52.       FactoryProc: TFactoryProc);
  53.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  54.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  55.   end;
  56.  
  57. { COM object }
  58.  
  59.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  60.   private
  61.     FRefCount: Integer;
  62.     FFactory: TComObjectFactory;
  63.     FController: Pointer;
  64.     function GetController: IUnknown;
  65.   protected
  66.     { IUnknown }
  67.     function IUnknown.QueryInterface = ObjQueryInterface;
  68.     function IUnknown._AddRef = ObjAddRef;
  69.     function IUnknown._Release = ObjRelease;
  70.     { IUnknown methods for other interfaces }
  71.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  72.     function _AddRef: Integer; stdcall;
  73.     function _Release: Integer; stdcall;
  74.     { ISupportErrorInfo }
  75.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  76.   public
  77.     constructor Create;
  78.     constructor CreateAggregated(const Controller: IUnknown);
  79.     constructor CreateFromFactory(Factory: TComObjectFactory;
  80.       const Controller: IUnknown);
  81.     destructor Destroy; override;
  82.     procedure Initialize; virtual;
  83.     function ObjAddRef: Integer; virtual; stdcall;
  84.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
  85.     function ObjRelease: Integer; virtual; stdcall;
  86.     function SafeCallException(ExceptObject: TObject;
  87.       ExceptAddr: Pointer): HResult; override;
  88.     property Controller: IUnknown read GetController;
  89.     property Factory: TComObjectFactory read FFactory;
  90.     property RefCount: Integer read FRefCount;
  91.   end;
  92.  
  93. { COM class }
  94.  
  95.   TComClass = class of TComObject;
  96.  
  97. { Instancing mode for COM classes }
  98.  
  99.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  100.  
  101. { COM object factory }
  102.  
  103.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  104.   private
  105.     FNext: TComObjectFactory;
  106.     FComServer: TComServerObject;
  107.     FComClass: TClass;
  108.     FClassID: TGUID;
  109.     FClassName: string;
  110.     FDescription: string;
  111.     FErrorIID: TGUID;
  112.     FInstancing: TClassInstancing;
  113.     FLicString: WideString;
  114.     FRegister: Longint;
  115.     FShowErrors: Boolean;
  116.     FSupportsLicensing: Boolean;
  117.   protected
  118.     function GetProgID: string; virtual;
  119.     function GetLicenseString: WideString; virtual;
  120.     function HasMachineLicense: Boolean; virtual;
  121.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  122.     { IUnknown }
  123.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  124.     function _AddRef: Integer; stdcall;
  125.     function _Release: Integer; stdcall;
  126.     { IClassFactory }
  127.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  128.       out Obj): HResult; stdcall;
  129.     function LockServer(fLock: BOOL): HResult; stdcall;
  130.     { IClassFactory2 }
  131.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  132.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  133.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  134.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  135.   public
  136.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  137.       const ClassID: TGUID; const ClassName, Description: string;
  138.       Instancing: TClassInstancing);
  139.     destructor Destroy; override;
  140.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  141.     procedure RegisterClassObject;
  142.     procedure UpdateRegistry(Register: Boolean); virtual;
  143.     property ClassID: TGUID read FClassID;
  144.     property ClassName: string read FClassName;
  145.     property ComClass: TClass read FComClass;
  146.     property ComServer: TComServerObject read FComServer;
  147.     property Description: string read FDescription;
  148.     property ErrorIID: TGUID read FErrorIID write FErrorIID;
  149.     property LicString: WideString read FLicString write FLicString;
  150.     property ProgID: string read GetProgID;
  151.     property Instancing: TClassInstancing read FInstancing;
  152.     property ShowErrors: Boolean read FShowErrors write FShowErrors;
  153.     property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing;
  154.   end;
  155.  
  156. { COM object with type information }
  157.  
  158.   TTypedComObject = class(TComObject, IProvideClassInfo)
  159.   protected
  160.     { IProvideClassInfo }
  161.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  162.   end;
  163.  
  164.   TTypedComClass = class of TTypedComObject;
  165.  
  166.   TTypedComObjectFactory = class(TComObjectFactory)
  167.   private
  168.     FClassInfo: ITypeInfo;
  169.   public
  170.     constructor Create(ComServer: TComServerObject;
  171.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  172.       Instancing: TClassInstancing);
  173.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  174.     procedure UpdateRegistry(Register: Boolean); override;
  175.     property ClassInfo: ITypeInfo read FClassInfo;
  176.   end;
  177.  
  178. { OLE Automation object }
  179.  
  180.   TAutoObject = class(TTypedComObject, IDispatch)
  181.   protected
  182.     { IDispatch }
  183.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  184.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  185.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  186.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  187.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  188.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  189.   end;
  190.  
  191. { OLE Automation class }
  192.  
  193.   TAutoClass = class of TAutoObject;
  194.  
  195. { OLE Automation object factory }
  196.  
  197.   TAutoObjectFactory = class(TTypedComObjectFactory)
  198.   private
  199.     FDispTypeInfo: ITypeInfo;
  200.     FDispIntfEntry: PInterfaceEntry;
  201.   public
  202.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  203.       const ClassID: TGUID; Instancing: TClassInstancing);
  204.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  205.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  206.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  207.   end;
  208.  
  209.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  210.   private
  211.     FDispTypeInfo: ITypeInfo;
  212.     FDispIntfEntry: PInterfaceEntry;
  213.     FDispIID: TGUID;
  214.   protected
  215.     { IDispatch }
  216.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  217.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  218.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  219.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  220.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  221.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  222.     { ISupportErrorInfo }
  223.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  224.   public
  225.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  226.     function SafeCallException(ExceptObject: TObject;
  227.       ExceptAddr: Pointer): HResult; override;
  228.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  229.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  230.     property DispIID: TGUID read FDispIID;
  231.   end;
  232.  
  233. { OLE exception classes }
  234.  
  235.   EOleError = class(Exception);
  236.  
  237.   EOleSysError = class(EOleError)
  238.   private
  239.     FErrorCode: Integer;
  240.   public
  241.     constructor Create(const Message: string; ErrorCode: Integer;
  242.       HelpContext: Integer);
  243.     property ErrorCode: Integer read FErrorCode write FErrorCode;
  244.   end;
  245.  
  246.   EOleException = class(EOleSysError)
  247.   private
  248.     FSource: string;
  249.     FHelpFile: string;
  250.   public
  251.     constructor Create(const Message: string; ErrorCode: Integer;
  252.       const Source, HelpFile: string; HelpContext: Integer);
  253.     property HelpFile: string read FHelpFile write FHelpFile;
  254.     property Source: string read FSource write FSource;
  255.   end;
  256.  
  257. { Dispatch call descriptor }
  258.  
  259.   PCallDesc = ^TCallDesc;
  260.   TCallDesc = packed record
  261.     CallType: Byte;
  262.     ArgCount: Byte;
  263.     NamedArgCount: Byte;
  264.     ArgTypes: array[0..255] of Byte;
  265.   end;
  266.  
  267.   PDispDesc = ^TDispDesc;
  268.   TDispDesc = packed record
  269.     DispID: Integer;
  270.     ResType: Byte;
  271.     CallDesc: TCallDesc;
  272.   end;
  273.  
  274. var
  275.   ComClassManager: TComClassManager;
  276.  
  277. function CreateComObject(const ClassID: TGUID): IUnknown;
  278. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  279. function CreateOleObject(const ClassName: string): IDispatch;
  280. function GetActiveOleObject(const ClassName: string): IDispatch;
  281.  
  282. procedure OleError(ErrorCode: HResult);
  283. procedure OleCheck(Result: HResult);
  284.  
  285. function StringToGUID(const S: string): TGUID;
  286. function GUIDToString(const ClassID: TGUID): string;
  287.  
  288. function ProgIDToClassID(const ProgID: string): TGUID;
  289. function ClassIDToProgID(const ClassID: TGUID): string;
  290.  
  291. procedure CreateRegKey(const Key, ValueName, Value: string);
  292. procedure DeleteRegKey(const Key: string);
  293.  
  294. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  295.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  296. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  297.  
  298. function HandleSafeCallException(ExceptObject: TObject;
  299.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  300.   HelpFileName: WideString): HResult;
  301.  
  302. function StringToLPOLESTR(const Source: string): POleStr;
  303.  
  304. procedure ReadPropFromBag(PropBag: IPropertyBag; ErrorLog: IErrorLog;
  305.   const Name: string; var Value: Variant);
  306. procedure PutPropInBag(PropBag: IPropertyBag; const Name: string;
  307.   const Value: Variant);
  308. procedure RegisterComServer(const DLLName: string);
  309.  
  310. implementation
  311.  
  312. {$I COMOBJ.INC}
  313.  
  314. const
  315.  
  316. { Maximum number of dispatch arguments }
  317.  
  318.   MaxDispArgs = 64; {!!!}
  319.  
  320. { Special variant type codes }
  321.  
  322.   varStrArg = $0048;
  323.  
  324. { Parameter type masks }
  325.  
  326.   atVarMask  = $3F;
  327.   atTypeMask = $7F;
  328.   atByRef    = $80;
  329.  
  330. var
  331.   OleUninitializing: Boolean;
  332.  
  333. { Raise EOleSysError exception from an error code }
  334.  
  335. procedure OleError(ErrorCode: HResult);
  336. begin
  337.   raise EOleSysError.Create('', ErrorCode, 0);
  338. end;
  339.  
  340. { Raise EOleSysError exception if result code indicates an error }
  341.  
  342. procedure OleCheck(Result: HResult);
  343. begin
  344.   if Result < 0 then OleError(Result);
  345. end;
  346.  
  347. { Convert a string to a GUID }
  348.  
  349. function StringToGUID(const S: string): TGUID;
  350. begin
  351.   OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
  352. end;
  353.  
  354. { Convert a GUID to a string }
  355.  
  356. function GUIDToString(const ClassID: TGUID): string;
  357. var
  358.   P: PWideChar;
  359. begin
  360.   OleCheck(StringFromCLSID(ClassID, P));
  361.   Result := P;
  362.   CoTaskMemFree(P);
  363. end;
  364.  
  365. { Convert a programmatic ID to a class ID }
  366.  
  367. function ProgIDToClassID(const ProgID: string): TGUID;
  368. begin
  369.   OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
  370. end;
  371.  
  372. { Convert a class ID to a programmatic ID }
  373.  
  374. function ClassIDToProgID(const ClassID: TGUID): string;
  375. var
  376.   P: PWideChar;
  377. begin
  378.   OleCheck(ProgIDFromCLSID(ClassID, P));
  379.   Result := P;
  380.   CoTaskMemFree(P);
  381. end;
  382.  
  383. { Create registry key }
  384.  
  385. procedure CreateRegKey(const Key, ValueName, Value: string);
  386. var
  387.   Handle: HKey;
  388.   Status, Disposition: Integer;
  389. begin
  390.   Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PChar(Key), 0, '',
  391.     REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
  392.     @Disposition);
  393.   if Status = 0 then
  394.   begin
  395.     Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_SZ,
  396.       PChar(Value), Length(Value) + 1);
  397.     RegCloseKey(Handle);
  398.   end;
  399.   if Status <> 0 then raise EOleError.Create(SCreateRegKeyError);
  400. end;
  401.  
  402. { Delete registry key }
  403.  
  404. procedure DeleteRegKey(const Key: string);
  405. begin
  406.   RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
  407. end;
  408.  
  409. function CreateComObject(const ClassID: TGUID): IUnknown;
  410. begin
  411.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  412.     CLSCTX_LOCAL_SERVER, IUnknown, Result));
  413. end;
  414.  
  415. type
  416.   TCoCreateInstanceExProc = function (const clsid: TCLSID;
  417.     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
  418.     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
  419.  
  420. var
  421.   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
  422.  
  423. function CreateRemoteComObject(const MachineName: WideString;
  424.   const ClassID: TGUID): IUnknown;
  425. var
  426.   MQI: TMultiQI;
  427.   Ole32: HModule;
  428.   ServerInfo: TCoServerInfo;
  429.   IID_IUnknown: TGuid;
  430. begin
  431.   if @CoCreateInstanceEx = nil then
  432.   begin
  433.     Ole32 := GetModuleHandle('ole32.dll');
  434.     Win32Check(Ole32 > HINSTANCE_ERROR);
  435.     @CoCreateInstanceEx := GetProcAddress(Ole32, 'CoCreateInstanceEx');
  436.     if @CoCreateInstanceEx = nil then
  437.       raise Exception.Create(SDCOMNotInstalled);
  438.   end;
  439.   FillChar(ServerInfo, sizeof(ServerInfo), 0);
  440.   ServerInfo.pwszName := PWideChar(MachineName);
  441.   IID_IUnknown := IUnknown;
  442.   MQI.IID := @IID_IUnknown;
  443.   MQI.itf := nil;
  444.   MQI.hr := 0;
  445.   OleCheck(CoCreateInstanceEx(ClassID, nil,
  446.     CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER,
  447.     @ServerInfo, 1, @MQI));
  448.   OleCheck(MQI.HR);
  449.   Result := MQI.itf;
  450. end;
  451.  
  452. function CreateOleObject(const ClassName: string): IDispatch;
  453. var
  454.   ClassID: TCLSID;
  455. begin
  456.   ClassID := ProgIDToClassID(ClassName);
  457.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  458.     CLSCTX_LOCAL_SERVER, IDispatch, Result));
  459. end;
  460.  
  461. function GetActiveOleObject(const ClassName: string): IDispatch;
  462. var
  463.   ClassID: TCLSID;
  464.   Unknown: IUnknown;
  465. begin
  466.   ClassID := ProgIDToClassID(ClassName);
  467.   OleCheck(GetActiveObject(ClassID, nil, Unknown));
  468.   OleCheck(Unknown.QueryInterface(IDispatch, Result));
  469. end;
  470.  
  471. procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
  472. var
  473.   ErrorInfo: IErrorInfo;
  474.   Source, Description, HelpFile: WideString;
  475.   HelpContext: Longint;
  476. begin
  477.   HelpContext := 0;
  478.   if GetErrorInfo(0, ErrorInfo) = S_OK then
  479.   begin
  480.     ErrorInfo.GetSource(Source);
  481.     ErrorInfo.GetDescription(Description);
  482.     ErrorInfo.GetHelpFile(HelpFile);
  483.     ErrorInfo.GetHelpContext(HelpContext);
  484.   end;
  485.   raise EOleException.Create(Description, ErrorCode, Source,
  486.     HelpFile, HelpContext) at ErrorAddr;
  487. end;
  488.  
  489. function TrimPunctuation(const S: string): string;
  490. var
  491.   Len: Integer;
  492. begin
  493.   Len := Length(S);
  494.   while (Len > 0) and (S[Len] in [#0..#32, '.']) do Dec(Len);
  495.   Result := Copy(S, 1, Len);
  496. end;
  497.  
  498. { Call Invoke method on the given IDispatch interface using the given
  499.   call descriptor, dispatch IDs, parameters, and result }
  500.  
  501. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  502.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  503. type
  504.   PVarArg = ^TVarArg;
  505.   TVarArg = array[0..3] of Integer;
  506.   TStringDesc = record
  507.     BStr: PWideChar;
  508.     PStr: PString;
  509.   end;
  510. var
  511.   I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
  512.   VarFlag: Byte;
  513.   ParamPtr: ^Integer;
  514.   ArgPtr, VarPtr: PVarArg;
  515.   DispParams: TDispParams;
  516.   ExcepInfo: TExcepInfo;
  517.   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  518.   Args: array[0..MaxDispArgs - 1] of TVarArg;
  519. begin
  520.   StrCount := 0;
  521.   try
  522.     ArgCount := CallDesc^.ArgCount;
  523.     if ArgCount <> 0 then
  524.     begin
  525.       ParamPtr := Params;
  526.       ArgPtr := @Args[ArgCount];
  527.       I := 0;
  528.       repeat
  529.         Dec(Integer(ArgPtr), SizeOf(TVarData));
  530.         ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
  531.         VarFlag := CallDesc^.ArgTypes[I] and atByRef;
  532.         if ArgType = varError then
  533.         begin
  534.           ArgPtr^[0] := varError;
  535.           ArgPtr^[2] := DISP_E_PARAMNOTFOUND;
  536.         end else
  537.         begin
  538.           if ArgType = varStrArg then
  539.           begin
  540.             with Strings[StrCount] do
  541.               if VarFlag <> 0 then
  542.               begin
  543.                 BStr := StringToOleStr(PString(ParamPtr^)^);
  544.                 PStr := PString(ParamPtr^);
  545.                 ArgPtr^[0] := varOleStr or varByRef;
  546.                 ArgPtr^[2] := Integer(@BStr);
  547.               end else
  548.               begin
  549.                 BStr := StringToOleStr(PString(ParamPtr)^);
  550.                 PStr := nil;
  551.                 ArgPtr^[0] := varOleStr;
  552.                 ArgPtr^[2] := Integer(BStr);
  553.               end;
  554.             Inc(StrCount);
  555.           end else
  556.           if VarFlag <> 0 then
  557.           begin
  558.             if (ArgType = varVariant) and
  559.               (PVarData(ParamPtr^)^.VType = varString) then
  560.               VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
  561.             ArgPtr^[0] := ArgType or varByRef;
  562.             ArgPtr^[2] := ParamPtr^;
  563.           end else
  564.           if ArgType = varVariant then
  565.           begin
  566.             if PVarData(ParamPtr)^.VType = varString then
  567.             begin
  568.               with Strings[StrCount] do
  569.               begin
  570.                 BStr := StringToOleStr(string(PVarData(ParamPtr^)^.VString));
  571.                 PStr := nil;
  572.                 ArgPtr^[0] := varOleStr;
  573.                 ArgPtr^[2] := Integer(BStr);
  574.               end;
  575.               Inc(StrCount);
  576.             end else
  577.             begin
  578.               VarPtr := PVarArg(ParamPtr);
  579.               ArgPtr^[0] := VarPtr^[0];
  580.               ArgPtr^[1] := VarPtr^[1];
  581.               ArgPtr^[2] := VarPtr^[2];
  582.               ArgPtr^[3] := VarPtr^[3];
  583.               Inc(Integer(ParamPtr), 12);
  584.             end;
  585.           end else
  586.           begin
  587.             ArgPtr^[0] := ArgType;
  588.             ArgPtr^[2] := ParamPtr^;
  589.             if (ArgType >= varDouble) and (ArgType <= varDate) then
  590.             begin
  591.               Inc(Integer(ParamPtr), 4);
  592.               ArgPtr^[3] := ParamPtr^;
  593.             end;
  594.           end;
  595.           Inc(Integer(ParamPtr), 4);
  596.         end;
  597.         Inc(I);
  598.       until I = ArgCount;
  599.     end;
  600.     DispParams.rgvarg := @Args;
  601.     DispParams.rgdispidNamedArgs := @DispIDs[1];
  602.     DispParams.cArgs := ArgCount;
  603.     DispParams.cNamedArgs := CallDesc^.NamedArgCount;
  604.     DispID := DispIDs[0];
  605.     InvKind := CallDesc^.CallType;
  606.     if InvKind = DISPATCH_PROPERTYPUT then
  607.     begin
  608.       if Args[0][0] and varTypeMask = varDispatch then
  609.         InvKind := DISPATCH_PROPERTYPUTREF;
  610.       DispIDs[0] := DISPID_PROPERTYPUT;
  611.       Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
  612.       Inc(DispParams.cNamedArgs);
  613.     end else
  614.       if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
  615.         InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  616.     Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
  617.       Result, @ExcepInfo, nil);
  618.     if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
  619.     J := StrCount;
  620.     while J <> 0 do
  621.     begin
  622.       Dec(J);
  623.       with Strings[J] do
  624.         if PStr <> nil then OleStrToStrVar(BStr, PStr^);
  625.     end;
  626.   finally
  627.     K := StrCount;
  628.     while K <> 0 do
  629.     begin
  630.       Dec(K);
  631.       SysFreeString(Strings[K].BStr);
  632.     end;
  633.   end;
  634. end;
  635.  
  636. { Raise exception given an OLE return code and TExcepInfo structure }
  637.  
  638. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  639. begin
  640.   if Status <> DISP_E_EXCEPTION then OleError(Status);
  641.   with ExcepInfo do
  642.     raise EOleException.Create(bstrDescription, scode, bstrSource,
  643.       bstrHelpFile, dwHelpContext);
  644. end;
  645.  
  646. { Call GetIDsOfNames method on the given IDispatch interface }
  647.  
  648. procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PChar;
  649.   NameCount: Integer; DispIDs: PDispIDList);
  650.  
  651.   procedure Error;
  652.   begin
  653.     raise EOleError.CreateFmt(SNoMethod, [Names]);
  654.   end;
  655.  
  656. type
  657.   PNamesArray = ^TNamesArray;
  658.   TNamesArray = array[0..0] of PWideChar;
  659. var
  660.   N, SrcLen, DestLen: Integer;
  661.   Src: PChar;
  662.   Dest: PWideChar;
  663.   NameRefs: PNamesArray;
  664.   StackTop: Pointer;
  665.   Temp: Integer;
  666. begin
  667.   Src := Names;
  668.   N := 0;
  669.   asm
  670.     MOV  StackTop, ESP
  671.     MOV  EAX, NameCount
  672.     INC  EAX
  673.     SHL  EAX, 2  // sizeof pointer = 4
  674.     SUB  ESP, EAX
  675.     LEA  EAX, NameRefs
  676.     MOV  [EAX], ESP
  677.   end;
  678.   repeat
  679.     SrcLen := StrLen(Src);
  680.     DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1;
  681.     asm
  682.       MOV  EAX, DestLen
  683.       ADD  EAX, EAX
  684.       ADD  EAX, 3      // round up to 4 byte boundary
  685.       AND  EAX, not 3
  686.       SUB  ESP, EAX
  687.       LEA  EAX, Dest
  688.       MOV  [EAX], ESP
  689.     end;
  690.     if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest;
  691.     MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen);
  692.     Dest[DestLen-1] := #0;
  693.     Inc(Src, SrcLen+1);
  694.     Inc(N);
  695.   until N = NameCount;
  696.   Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount,
  697.     GetThreadLocale, DispIDs);
  698.   if Temp = DISP_E_UNKNOWNNAME then Error else OleCheck(Temp);
  699.   asm
  700.     MOV  ESP, StackTop
  701.   end;
  702. end;
  703.  
  704. { Central call dispatcher }
  705.  
  706. procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
  707.   CallDesc: PCallDesc; Params: Pointer); cdecl;
  708. var
  709.   Dispatch: Pointer;
  710.   DispIDs: array[0..MaxDispArgs - 1] of Integer;
  711. begin
  712.   if TVarData(Instance).VType = varDispatch then
  713.     Dispatch := TVarData(Instance).VDispatch
  714.   else if TVarData(Instance).VType = (varDispatch or varByRef) then
  715.     Dispatch := Pointer(TVarData(Instance).VPointer^)
  716.   else
  717.     raise EOleError.Create(SVarNotObject);
  718.   GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
  719.     CallDesc^.NamedArgCount + 1, @DispIDs);
  720.   if Result <> nil then VarClear(Result^);
  721.   DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
  722. end;
  723.  
  724. { Raise exception given an OLE return code and TExcepInfo structure }
  725.  
  726. procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo;
  727.   ErrorAddr: Pointer);
  728. var
  729.   E: Exception;
  730. begin
  731.   if Status = DISP_E_EXCEPTION then
  732.   begin
  733.     with ExcepInfo do
  734.       E := EOleException.Create(bstrDescription, scode, bstrSource,
  735.         bstrHelpFile, dwHelpContext);
  736.     Finalize(ExcepInfo);
  737.   end else
  738.     E := EOleSysError.Create('', Status, 0);
  739.   raise E at ErrorAddr;
  740. end;
  741.  
  742. procedure ClearExcepInfo(var ExcepInfo: TExcepInfo);
  743. begin
  744.   FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
  745. end;
  746.  
  747. procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc;
  748.   DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall;
  749. type
  750.   TExcepInfoRec = record
  751.     wCode: Word;
  752.     wReserved: Word;
  753.     bstrSource: PWideChar;
  754.     bstrDescription: PWideChar;
  755.     bstrHelpFile: PWideChar;
  756.     dwHelpContext: Longint;
  757.     pvReserved: Pointer;
  758.     pfnDeferredFillIn: Pointer;
  759.     scode: HResult;
  760.   end;
  761. var
  762.   DispParams: TDispParams;
  763.   ExcepInfo: TExcepInfoRec;
  764. asm
  765.         PUSH    EBX
  766.         PUSH    ESI
  767.         PUSH    EDI
  768.         MOV     EBX,CallDesc
  769.         XOR     EDX,EDX
  770.         MOV     EDI,ESP
  771.         MOVZX   ECX,[EBX].TCallDesc.ArgCount
  772.         MOV     DispParams.cArgs,ECX
  773.         TEST    ECX,ECX
  774.         JE      @@10
  775.         ADD     EBX,OFFSET TCallDesc.ArgTypes
  776.         MOV     ESI,Params
  777. @@1:    MOVZX   EAX,[EBX].Byte
  778.         TEST    AL,atByRef
  779.         JNE     @@3
  780.         CMP     AL,varVariant
  781.         JE      @@2
  782.         CMP     AL,varDouble
  783.         JB      @@4
  784.         CMP     AL,varDate
  785.         JA      @@4
  786.         PUSH    [ESI].Integer[4]
  787.         PUSH    [ESI].Integer[0]
  788.         PUSH    EDX
  789.         PUSH    EAX
  790.         ADD     ESI,8
  791.         JMP     @@5
  792. @@2:    PUSH    [ESI].Integer[12]
  793.         PUSH    [ESI].Integer[8]
  794.         PUSH    [ESI].Integer[4]
  795.         PUSH    [ESI].Integer[0]
  796.         ADD     ESI,16
  797.         JMP     @@5
  798. @@3:    AND     AL,atTypeMask
  799.         OR      EAX,varByRef
  800. @@4:    PUSH    EDX
  801.         PUSH    [ESI].Integer[0]
  802.         PUSH    EDX
  803.         PUSH    EAX
  804.         ADD     ESI,4
  805. @@5:    INC     EBX
  806.         DEC     ECX
  807.         JNE     @@1
  808.         MOV     EBX,CallDesc
  809. @@10:   MOV     DispParams.rgvarg,ESP
  810.         MOVZX   EAX,[EBX].TCallDesc.NamedArgCount
  811.         MOV     DispParams.cNamedArgs,EAX
  812.         TEST    EAX,EAX
  813.         JE      @@12
  814.         MOV     ESI,NamedArgDispIDs
  815. @@11:   PUSH    [ESI].Integer[EAX*4-4]
  816.         DEC     EAX
  817.         JNE     @@11
  818. @@12:   MOVZX   ECX,[EBX].TCallDesc.CallType
  819.         CMP     ECX,DISPATCH_PROPERTYPUT
  820.         JNE     @@20
  821.         PUSH    DISPID_PROPERTYPUT
  822.         INC     DispParams.cNamedArgs
  823.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch
  824.         JE      @@13
  825.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown
  826.         JNE     @@20
  827. @@13:   MOV     ECX,DISPATCH_PROPERTYPUTREF
  828. @@20:   MOV     DispParams.rgdispidNamedArgs,ESP
  829.         PUSH    EDX                     { ArgErr }
  830.         LEA     EAX,ExcepInfo
  831.         PUSH    EAX                     { ExcepInfo }
  832.         PUSH    ECX
  833.         PUSH    EDX
  834.         CALL    ClearExcepInfo
  835.         POP     EDX
  836.         POP     ECX
  837.         PUSH    Result                  { VarResult }
  838.         LEA     EAX,DispParams
  839.         PUSH    EAX                     { Params }
  840.         PUSH    ECX                     { Flags }
  841.         PUSH    EDX                     { LocaleID }
  842.         PUSH    OFFSET GUID_NULL        { IID }
  843.         PUSH    DispID                  { DispID }
  844.         MOV     EAX,Dispatch
  845.         PUSH    EAX
  846.         MOV     EAX,[EAX]
  847.         CALL    [EAX].Pointer[24]
  848.         TEST    EAX,EAX
  849.         JE      @@30
  850.         LEA     EDX,ExcepInfo
  851.         MOV     ECX,[EBP+4]
  852.         JMP     DispCallError
  853. @@30:   MOV     ESP,EDI
  854.         POP     EDI
  855.         POP     ESI
  856.         POP     EBX
  857. end;
  858.  
  859. procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch;
  860.   DispDesc: PDispDesc; Params: Pointer); cdecl;
  861. asm
  862.         PUSH    EBX
  863.         MOV     EBX,DispDesc
  864.         XOR     EAX,EAX
  865.         PUSH    EAX
  866.         PUSH    EAX
  867.         PUSH    EAX
  868.         PUSH    EAX
  869.         MOV     EAX,ESP
  870.         PUSH    EAX
  871.         LEA     EAX,Params
  872.         PUSH    EAX
  873.         PUSH    EAX
  874.         PUSH    [EBX].TDispDesc.DispID
  875.         LEA     EAX,[EBX].TDispDesc.CallDesc
  876.         PUSH    EAX
  877.         PUSH    Dispatch
  878.         CALL    DispCall
  879.         MOVZX   EAX,[EBX].TDispDesc.ResType
  880.         MOV     EBX,Result
  881.         JMP     @ResultTable.Pointer[EAX*4]
  882.  
  883. @ResultTable:
  884.         DD      @ResEmpty
  885.         DD      @ResNull
  886.         DD      @ResSmallint
  887.         DD      @ResInteger
  888.         DD      @ResSingle
  889.         DD      @ResDouble
  890.         DD      @ResCurrency
  891.         DD      @ResDate
  892.         DD      @ResString
  893.         DD      @ResDispatch
  894.         DD      @ResError
  895.         DD      @ResBoolean
  896.         DD      @ResVariant
  897.         DD      @ResUnknown
  898.         DD      @ResDecimal
  899.         DD      @ResError
  900.         DD      @ResByte
  901.  
  902. @ResSingle:
  903.         FLD     [ESP+8].Single
  904.         JMP     @ResDone
  905.  
  906. @ResDouble:
  907. @ResDate:
  908.         FLD     [ESP+8].Double
  909.         JMP     @ResDone
  910.  
  911. @ResCurrency:
  912.         FILD    [ESP+8].Currency
  913.         JMP     @ResDone
  914.  
  915. @ResString:
  916.         MOV     EAX,[EBX]
  917.         TEST    EAX,EAX
  918.         JE      @@1
  919.         PUSH    EAX
  920.         CALL    SysFreeString
  921. @@1:    MOV     EAX,[ESP+8]
  922.         MOV     [EBX],EAX
  923.         JMP     @ResDone
  924.  
  925. @ResDispatch:
  926. @ResUnknown:
  927.         MOV     EAX,[EBX]
  928.         TEST    EAX,EAX
  929.         JE      @@2
  930.         PUSH    EAX
  931.         MOV     EAX,[EAX]
  932.         CALL    [EAX].Pointer[8]
  933. @@2:    MOV     EAX,[ESP+8]
  934.         MOV     [EBX],EAX
  935.         JMP     @ResDone
  936.  
  937. @ResVariant:
  938.         MOV     EAX,EBX
  939.         CALL    System.@VarClear
  940.         MOV     EAX,[ESP]
  941.         MOV     [EBX],EAX
  942.         MOV     EAX,[ESP+4]
  943.         MOV     [EBX+4],EAX
  944.         MOV     EAX,[ESP+8]
  945.         MOV     [EBX+8],EAX
  946.         MOV     EAX,[ESP+12]
  947.         MOV     [EBX+12],EAX
  948.         JMP     @ResDone
  949.  
  950. @ResSmallint:
  951. @ResInteger:
  952. @ResBoolean:
  953. @ResByte:
  954.         MOV     EAX,[ESP+8]
  955.  
  956. @ResDecimal:
  957. @ResEmpty:
  958. @ResNull:
  959. @ResError:
  960. @ResDone:
  961.         ADD     ESP,16
  962.         POP     EBX
  963. end;
  964.  
  965. { Handle a safe call exception }
  966.  
  967. function HandleSafeCallException(ExceptObject: TObject;
  968.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  969.   HelpFileName: WideString): HResult;
  970. var
  971.   E: TObject;
  972.   CreateError: ICreateErrorInfo;
  973.   ErrorInfo: IErrorInfo;
  974. begin
  975.   Result := E_UNEXPECTED;
  976.   E := ExceptObject;
  977.   if CreateErrorInfo(CreateError) = S_OK then
  978.   begin
  979.     CreateError.SetGUID(ErrorIID);
  980.     if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID));
  981.     if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName));
  982.     if E is Exception then
  983.     begin
  984.       CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
  985.       CreateError.SetHelpContext(Exception(E).HelpContext);
  986.       if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
  987.         Result := EOleSysError(E).ErrorCode;
  988.     end;
  989.     if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
  990.       SetErrorInfo(0, ErrorInfo);
  991.   end;
  992. end;
  993.  
  994. { EOleSysError }
  995.  
  996. constructor EOleSysError.Create(const Message: string;
  997.   ErrorCode, HelpContext: Integer);
  998. var
  999.   S: string;
  1000. begin
  1001.   S := Message;
  1002.   if S = '' then
  1003.   begin
  1004.     S := SysErrorMessage(ErrorCode);
  1005.     if S = '' then FmtStr(S, SOleError, [ErrorCode]);
  1006.   end;
  1007.   inherited CreateHelp(S, HelpContext);
  1008.   FErrorCode := ErrorCode;
  1009. end;
  1010.  
  1011. { EOleException }
  1012.  
  1013. constructor EOleException.Create(const Message: string; ErrorCode: Integer;
  1014.   const Source, HelpFile: string; HelpContext: Integer);
  1015. begin
  1016.   inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext);
  1017.   FSource := Source;
  1018.   FHelpFile := HelpFile;
  1019. end;
  1020.  
  1021. { TComClassManager }
  1022.  
  1023. procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory);
  1024. begin
  1025.   Factory.FNext := FFactoryList;
  1026.   FFactoryList := Factory;
  1027. end;
  1028.  
  1029. procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
  1030.   FactoryProc: TFactoryProc);
  1031. var
  1032.   Factory, Next: TComObjectFactory;
  1033. begin
  1034.   Factory := FFactoryList;
  1035.   while Factory <> nil do
  1036.   begin
  1037.     Next := Factory.FNext;
  1038.     if Factory.ComServer = ComServer then FactoryProc(Factory);
  1039.     Factory := Next;
  1040.   end;
  1041. end;
  1042.  
  1043. function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  1044. begin
  1045.   Result := FFactoryList;
  1046.   while Result <> nil do
  1047.   begin
  1048.     if Result.ComClass = ComClass then Exit;
  1049.     Result := Result.FNext;
  1050.   end;
  1051.   raise EOleError.CreateFmt(SObjectFactoryMissing, [ComClass.ClassName]);
  1052. end;
  1053.  
  1054. function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  1055. begin
  1056.   Result := FFactoryList;
  1057.   while Result <> nil do
  1058.   begin
  1059.     if IsEqualGUID(Result.ClassID, ClassID) then Exit;
  1060.     Result := Result.FNext;
  1061.   end;
  1062. end;
  1063.  
  1064. procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory);
  1065. var
  1066.   F, P: TComObjectFactory;
  1067. begin
  1068.   P := nil;
  1069.   F := FFactoryList;
  1070.   while F <> nil do
  1071.   begin
  1072.     if F = Factory then
  1073.     begin
  1074.       if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext;
  1075.       Exit;
  1076.     end;
  1077.     P := F;
  1078.     F := F.FNext;
  1079.   end;
  1080. end;
  1081.  
  1082. { TComObject }
  1083.  
  1084. constructor TComObject.Create;
  1085. begin
  1086.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil);
  1087. end;
  1088.  
  1089. constructor TComObject.CreateAggregated(const Controller: IUnknown);
  1090. begin
  1091.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller);
  1092. end;
  1093.  
  1094. constructor TComObject.CreateFromFactory(Factory: TComObjectFactory;
  1095.   const Controller: IUnknown);
  1096. begin
  1097.   FRefCount := 1;
  1098.   FFactory := Factory;
  1099.   FController := Pointer(Controller);
  1100.   FFactory.ComServer.CountObject(True);
  1101.   Initialize;
  1102.   Dec(FRefCount);
  1103. end;
  1104.  
  1105. destructor TComObject.Destroy;
  1106. begin
  1107.   if not OleUninitializing and (FFactory <> nil) then
  1108.     FFactory.ComServer.CountObject(False);
  1109. end;
  1110.  
  1111. function TComObject.GetController: IUnknown;
  1112. begin
  1113.   Result := IUnknown(FController);
  1114. end;
  1115.  
  1116. procedure TComObject.Initialize;
  1117. begin
  1118. end;
  1119.  
  1120. function TComObject.SafeCallException(ExceptObject: TObject;
  1121.   ExceptAddr: Pointer): HResult;
  1122. begin
  1123.   Result := HandleSafeCallException(ExceptObject, ExceptAddr,
  1124.     FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);
  1125. end;
  1126.  
  1127. { TComObject.IUnknown }
  1128.  
  1129. function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
  1130. begin
  1131.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1132. end;
  1133.  
  1134. function TComObject.ObjAddRef: Integer;
  1135. begin
  1136.   Inc(FRefCount);
  1137.   Result := FRefCount;
  1138. end;
  1139.  
  1140. function TComObject.ObjRelease: Integer;
  1141. begin
  1142.   Dec(FRefCount);
  1143.   if FRefCount = 0 then
  1144.   begin
  1145.     Destroy;
  1146.     Result := 0;
  1147.     Exit;
  1148.   end;
  1149.   Result := FRefCount;
  1150. end;
  1151.  
  1152. { TComObject.IUnknown for other interfaces }
  1153.  
  1154. function TComObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  1155. begin
  1156.   if FController <> nil then
  1157.     Result := IUnknown(FController).QueryInterface(IID, Obj) else
  1158.     Result := ObjQueryInterface(IID, Obj);
  1159. end;
  1160.  
  1161. function TComObject._AddRef: Integer;
  1162. begin
  1163.   if FController <> nil then
  1164.     Result := IUnknown(FController)._AddRef else
  1165.     Result := ObjAddRef;
  1166. end;
  1167.  
  1168. function TComObject._Release: Integer;
  1169. begin
  1170.   if FController <> nil then
  1171.     Result := IUnknown(FController)._Release else
  1172.     Result := ObjRelease;
  1173. end;
  1174.  
  1175. { TComObject.ISupportErrorInfo }
  1176.  
  1177. function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  1178. begin
  1179.   if GetInterfaceEntry(iid) <> nil then
  1180.     Result := S_OK else
  1181.     Result := S_FALSE;
  1182. end;
  1183.  
  1184. { TComObjectFactory }
  1185.  
  1186. constructor TComObjectFactory.Create(ComServer: TComServerObject;
  1187.   ComClass: TComClass; const ClassID: TGUID; const ClassName,
  1188.   Description: string; Instancing: TClassInstancing);
  1189. begin
  1190.   ComClassManager.AddObjectFactory(Self);
  1191.   FComServer := ComServer;
  1192.   FComClass := ComClass;
  1193.   FClassID := ClassID;
  1194.   FClassName := ClassName;
  1195.   FDescription := Description;
  1196.   FInstancing := Instancing;
  1197.   FErrorIID := IUnknown;
  1198.   FShowErrors := True;
  1199. end;
  1200.  
  1201. destructor TComObjectFactory.Destroy;
  1202. begin
  1203.   if FRegister <> 0 then CoRevokeClassObject(FRegister);
  1204.   ComClassManager.RemoveObjectFactory(Self);
  1205. end;
  1206.  
  1207. function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
  1208. begin
  1209.   Result := TComClass(FComClass).CreateFromFactory(Self, Controller);
  1210. end;
  1211.  
  1212. function TComObjectFactory.GetProgID: string;
  1213. begin
  1214.   if FClassName <> '' then
  1215.     Result := FComServer.ServerName + '.' + FClassName else
  1216.     Result := '';
  1217. end;
  1218.  
  1219. procedure TComObjectFactory.RegisterClassObject;
  1220. const
  1221.   RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = (
  1222.     REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
  1223. begin
  1224.   if FInstancing <> ciInternal then
  1225.     OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
  1226.       RegFlags[FInstancing], FRegister));
  1227. end;
  1228.  
  1229. procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
  1230. var
  1231.   ClassID, ProgID, Temp: string;
  1232. begin
  1233.   if FInstancing = ciInternal then Exit;
  1234.   ClassID := GUIDToString(FClassID);
  1235.   ProgID := GetProgID;
  1236.   if Register then
  1237.   begin
  1238.     CreateRegKey('CLSID\' + ClassID, '', Description);
  1239.     Temp := FComServer.ServerFileName;
  1240.     if AnsiPos(' ',Temp) <> 0 then
  1241.       Temp := '"'+Temp+'"';
  1242.     CreateRegKey('CLSID\' + ClassID + '\' + FComServer.ServerKey,
  1243.       '', Temp);
  1244.     if ProgID <> '' then
  1245.     begin
  1246.       CreateRegKey(ProgID, '', Description);
  1247.       CreateRegKey(ProgID + '\Clsid', '', ClassID);
  1248.       CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID);
  1249.     end;
  1250.   end else
  1251.   begin
  1252.     if ProgID <> '' then
  1253.     begin
  1254.       DeleteRegKey('CLSID\' + ClassID + '\ProgID');
  1255.       DeleteRegKey(ProgID + '\Clsid');
  1256.       DeleteRegKey(ProgID);
  1257.     end;
  1258.     DeleteRegKey('CLSID\' + ClassID + '\' + FComServer.ServerKey);
  1259.     DeleteRegKey('CLSID\' + ClassID);
  1260.   end;
  1261. end;
  1262.  
  1263. function TComObjectFactory.GetLicenseString: WideString;
  1264. begin
  1265.   if FSupportsLicensing then Result := FLicString
  1266.   else Result := '';
  1267. end;
  1268.  
  1269. function TComObjectFactory.HasMachineLicense: Boolean;
  1270. begin
  1271.   Result := True;
  1272. end;
  1273.  
  1274. function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean;
  1275. begin
  1276.   Result := AnsiCompareText(LicStr, FLicString) = 0;
  1277. end;
  1278.  
  1279. { TComObjectFactory.IUnknown }
  1280.  
  1281. function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): Integer;
  1282. begin
  1283.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1284. end;
  1285.  
  1286. function TComObjectFactory._AddRef: Integer;
  1287. begin
  1288.   Result := ComServer.CountFactory(True);
  1289. end;
  1290.  
  1291. function TComObjectFactory._Release: Integer;
  1292. begin
  1293.   Result := ComServer.CountFactory(False);
  1294. end;
  1295.  
  1296. { TComObjectFactory.IClassFactory }
  1297.  
  1298. function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
  1299.   const IID: TGUID; out Obj): HResult;
  1300. begin
  1301.   Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj);
  1302. end;
  1303.  
  1304. function TComObjectFactory.LockServer(fLock: BOOL): HResult;
  1305. begin
  1306.   Result := CoLockObjectExternal(Self, fLock, True);
  1307. end;
  1308.  
  1309. { TComObjectFactory.IClassFactory2 }
  1310.  
  1311. function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult;
  1312. begin
  1313.   Result := S_OK;
  1314.   try
  1315.     with licInfo do
  1316.     begin
  1317.       cbLicInfo := SizeOf(licInfo);
  1318.       fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> '');
  1319.       fLicVerified := (not FSupportsLicensing) or HasMachineLicense;
  1320.     end;
  1321.   except
  1322.     Result := E_UNEXPECTED;
  1323.   end;
  1324. end;
  1325.  
  1326. function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult;
  1327. begin
  1328.   // Can't give away a license key on an unlicensed machine
  1329.   if not HasMachineLicense then
  1330.   begin
  1331.     Result := CLASS_E_NOTLICENSED;
  1332.     Exit;
  1333.   end;
  1334.   bstrKey := FLicString;
  1335.   Result := NOERROR;
  1336. end;
  1337.  
  1338. function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown;
  1339.   const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString;
  1340.   out vObject): HResult; stdcall;
  1341. var
  1342.   ComObject: TComObject;
  1343. begin
  1344.   if FSupportsLicensing and
  1345.     ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or
  1346.     ((bstrKey = '') and (not HasMachineLicense)) then
  1347.   begin
  1348.     Result := CLASS_E_NOTLICENSED;
  1349.     Exit;
  1350.   end;
  1351.   Pointer(vObject) := nil;
  1352.   try
  1353.     ComObject := CreateComObject(UnkOuter);
  1354.   except
  1355.     if FShowErrors and (ExceptObject is Exception) then
  1356.       with Exception(ExceptObject) do
  1357.       begin
  1358.         if (Message <> '') and (AnsiLastChar(Message) > '.') then
  1359.           Message := Message + '.';
  1360.         MessageBox(0, PChar(Message), PChar(SDAXError), MB_OK or MB_ICONSTOP or
  1361.           MB_SETFOREGROUND);
  1362.       end;
  1363.     Result := E_UNEXPECTED;
  1364.     Exit;
  1365.   end;
  1366.   Result := ComObject.ObjQueryInterface(IID, vObject);
  1367.   if ComObject.RefCount = 0 then ComObject.Free;
  1368. end;
  1369.  
  1370. { TTypedComObject.IProvideClassInfo }
  1371.  
  1372. function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
  1373. begin
  1374.   TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo;
  1375.   Result := S_OK;
  1376. end;
  1377.  
  1378. { TTypedComObjectFactory }
  1379.  
  1380. constructor TTypedComObjectFactory.Create(ComServer: TComServerObject;
  1381.   TypedComClass: TTypedComClass; const ClassID: TGUID;
  1382.   Instancing: TClassInstancing);
  1383. var
  1384.   ClassName, Description: WideString;
  1385. begin
  1386.   if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then
  1387.     raise EOleError.CreateFmt(STypeInfoMissing, [TypedComClass.ClassName]);
  1388.   OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName,
  1389.     @Description, nil, nil));
  1390.   inherited Create(ComServer, TypedComClass, ClassID,
  1391.     ClassName, Description, Instancing);
  1392. end;
  1393.  
  1394. function TTypedComObjectFactory.GetInterfaceTypeInfo(
  1395.   TypeFlags: Integer): ITypeInfo;
  1396. const
  1397.   FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE;
  1398. var
  1399.   ClassAttr: PTypeAttr;
  1400.   I, TypeInfoCount, Flags: Integer;
  1401.   RefType: HRefType;
  1402. begin
  1403.   OleCheck(FClassInfo.GetTypeAttr(ClassAttr));
  1404.   TypeInfoCount := ClassAttr^.cImplTypes;
  1405.   ClassInfo.ReleaseTypeAttr(ClassAttr);
  1406.   for I := 0 to TypeInfoCount - 1 do
  1407.   begin
  1408.     OleCheck(ClassInfo.GetImplTypeFlags(I, Flags));
  1409.     if Flags and FlagsMask = TypeFlags then
  1410.     begin
  1411.       OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType));
  1412.       OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
  1413.       Exit;
  1414.     end;
  1415.   end;
  1416.   Result := nil;
  1417. end;
  1418.  
  1419. procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
  1420. var
  1421.   ClassKey: string;
  1422.   TypeLib: ITypeLib;
  1423.   TLibAttr: PTLibAttr;
  1424. begin
  1425.   ClassKey := 'CLSID\' + GUIDToString(FClassID);
  1426.   if Register then
  1427.   begin
  1428.     inherited UpdateRegistry(Register);
  1429.     TypeLib := FComServer.TypeLib;
  1430.     OleCheck(TypeLib.GetLibAttr(TLibAttr));
  1431.     try
  1432.       CreateRegKey(ClassKey + '\Version', '', Format('%d.%d',
  1433.         [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum]));
  1434.       CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid));
  1435.     finally
  1436.       TypeLib.ReleaseTLibAttr(TLibAttr);
  1437.     end;
  1438.   end else
  1439.   begin
  1440.     DeleteRegKey(ClassKey + '\TypeLib');
  1441.     DeleteRegKey(ClassKey + '\Version');
  1442.     inherited UpdateRegistry(Register);
  1443.   end;
  1444. end;
  1445.  
  1446. { TAutoObject.IDispatch }
  1447.  
  1448. function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1449.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1450. begin
  1451.   Result := DispGetIDsOfNames(TAutoObjectFactory(Factory).DispTypeInfo,
  1452.     Names, NameCount, DispIDs);
  1453. end;
  1454.  
  1455. function TAutoObject.GetTypeInfo(Index, LocaleID: Integer;
  1456.   out TypeInfo): HResult;
  1457. begin
  1458.   Pointer(TypeInfo) := nil;
  1459.   if Index <> 0 then
  1460.   begin
  1461.     Result := DISP_E_BADINDEX;
  1462.     Exit;
  1463.   end;
  1464.   ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo;
  1465.   Result := S_OK;
  1466. end;
  1467.  
  1468. function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
  1469. begin
  1470.   Count := 1;
  1471.   Result := S_OK;
  1472. end;
  1473.  
  1474. function TAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1475.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  1476. const
  1477.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1478. begin
  1479.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1480.   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
  1481.     Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
  1482.     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  1483. end;
  1484.  
  1485. { TAutoObjectFactory }
  1486.  
  1487. constructor TAutoObjectFactory.Create(ComServer: TComServerObject;
  1488.   AutoClass: TAutoClass; const ClassID: TGUID;
  1489.   Instancing: TClassInstancing);
  1490. var
  1491.   TypeAttr: PTypeAttr;
  1492. begin
  1493.   inherited Create(ComServer, AutoClass, ClassID, Instancing);
  1494.   FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
  1495.   if FDispTypeInfo = nil then
  1496.     raise EOleError.CreateFmt(SBadTypeInfo, [AutoClass.ClassName]);
  1497.   OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr));
  1498. //  FDispIntfEntry := AutoClass.GetInterfaceEntry(TypeAttr^.guid);
  1499.   FDispIntfEntry := GetIntfEntry(TypeAttr^.guid);
  1500.   FDispTypeInfo.ReleaseTypeAttr(TypeAttr);
  1501.   if FDispIntfEntry = nil then
  1502.     raise EOleError.CreateFmt(SDispIntfMissing, [AutoClass.ClassName]);
  1503.   FErrorIID := FDispIntfEntry^.IID;
  1504. end;
  1505.  
  1506. function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
  1507. begin
  1508.   Result := FComClass.GetInterfaceEntry(Guid);
  1509. end;
  1510.  
  1511. { TAutoIntfObject }
  1512.  
  1513. constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  1514. begin
  1515.   OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo));
  1516.   FDispIntfEntry := GetInterfaceEntry(DispIntf);
  1517. end;
  1518.  
  1519. { TAutoIntfObject.IDispatch }
  1520.  
  1521. function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1522.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1523. begin
  1524.   Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs);
  1525. end;
  1526.  
  1527. function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer;
  1528.   out TypeInfo): HResult;
  1529. begin
  1530.   Pointer(TypeInfo) := nil;
  1531.   if Index <> 0 then
  1532.   begin
  1533.     Result := DISP_E_BADINDEX;
  1534.     Exit;
  1535.   end;
  1536.   ITypeInfo(TypeInfo) := FDispTypeInfo;
  1537.   Result := S_OK;
  1538. end;
  1539.  
  1540. function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult;
  1541. begin
  1542.   Count := 1;
  1543.   Result := S_OK;
  1544. end;
  1545.  
  1546. function TAutoIntfObject.Invoke(DispID: Integer; const IID: TGUID;
  1547.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  1548.   ArgErr: Pointer): HResult;
  1549. const
  1550.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1551. begin
  1552.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1553.   Result := FDispTypeInfo.Invoke(Pointer(Integer(Self) +
  1554.     FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult,
  1555.     ExcepInfo, ArgErr);
  1556. end;
  1557.  
  1558. function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  1559. begin
  1560.   if IsEqualGUID(DispIID, iid) then
  1561.     Result := S_OK else
  1562.     Result := S_FALSE;
  1563. end;
  1564.  
  1565. function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
  1566.   ExceptAddr: Pointer): HResult;
  1567. begin
  1568.   Result := HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', '');
  1569. end;
  1570.  
  1571. function StringToLPOLESTR(const Source: string): POleStr;
  1572. var
  1573.   SourceLen: Integer;
  1574.   Buffer: PWideChar;
  1575. begin
  1576.   SourceLen := Length(Source);
  1577.   Buffer  := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar));
  1578.   StringToWideChar( Source, Buffer, SourceLen+1 );
  1579.   Result := POleStr( Buffer );
  1580. end;
  1581.  
  1582. // ----------------------------------------------------------------------
  1583. // Property helpers
  1584. // TODO: these should probably end up as "TPropBag..."
  1585. // ----------------------------------------------------------------------
  1586. procedure ReadPropFromBag( PropBag: IPropertyBag; ErrorLog: IErrorLog; const Name: string; var Value: Variant);
  1587. var
  1588.   ws: PWideChar;
  1589.   hRes: HResult;
  1590.   OleValue: OleVariant;
  1591. begin
  1592.   ws := StringToOleStr( Name );   //!! Use WideString type?
  1593.   hRes := PropBag.Read( ws, OleValue, ErrorLog );
  1594.   Value := OleValue;
  1595.   SysFreeString(ws);
  1596.   // on error: if the requested property is not found, clear the result, else throw exception
  1597.   if FAILED(hRes) then
  1598.     if hRes = E_INVALIDARG then
  1599.       VarClear( Value )
  1600.     else
  1601.       OleCheck( hRes );
  1602. end;
  1603.  
  1604. procedure PutPropInBag( PropBag: IPropertyBag; const Name: String; const Value: Variant);
  1605. var
  1606.   ws: PWideChar;
  1607. begin
  1608.   ws := StringToOleStr( Name );  //!! Use WideString type?
  1609.   OleCheck(PropBag.Write( ws, Value ));
  1610.   SysFreeString(ws);
  1611. end;
  1612.  
  1613. procedure RegisterComServer(const DLLName: string);
  1614. type
  1615.   TRegProc = function: HResult; stdcall;
  1616. const
  1617.   RegProcName = 'DllRegisterServer'; { Do not localize }
  1618. var
  1619.   Handle: THandle;
  1620.   RegProc: TRegProc;
  1621. begin
  1622.   Handle := LoadLibrary(PChar(DLLName));
  1623.   if Handle <= HINSTANCE_ERROR then
  1624.     raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), DLLName]);
  1625.   try
  1626.     RegProc := GetProcAddress(Handle, RegProcName);
  1627.     if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error;
  1628.   finally
  1629.     FreeLibrary(Handle);
  1630.   end;
  1631. end;
  1632.  
  1633. initialization
  1634. begin
  1635.   CoInitialize(nil);
  1636.   ComClassManager := TComClassManager.Create;
  1637.   SafeCallErrorProc := @SafeCallError;
  1638.   VarDispProc := @VarDispInvoke;
  1639.   DispCallByIDProc := @DispCallByID;
  1640. end;
  1641.  
  1642. finalization
  1643. begin
  1644.   OleUninitializing := True;
  1645.   DispCallByIDProc := nil;
  1646.   VarDispProc := nil;
  1647.   SafeCallErrorProc := nil;
  1648.   ComClassManager.Free;
  1649.   CoUninitialize;
  1650. end;
  1651.  
  1652. end.
  1653.