diff options
Diffstat (limited to 'plugins/Libs/kolcomobj.pas')
| -rw-r--r-- | plugins/Libs/kolcomobj.pas | 2352 |
1 files changed, 2352 insertions, 0 deletions
diff --git a/plugins/Libs/kolcomobj.pas b/plugins/Libs/kolcomobj.pas new file mode 100644 index 0000000000..8d8010906a --- /dev/null +++ b/plugins/Libs/kolcomobj.pas @@ -0,0 +1,2352 @@ +
+{*******************************************************}
+{ }
+{ Borland Delphi Runtime Library }
+{ COM object support }
+{ }
+{ Copyright (C) 1997,99 Inprise Corporation }
+{ }
+{*******************************************************}
+
+{$IMPORTEDDATA ON}
+unit KOLComObj;
+
+{$G+}
+{$DEFINE NOWARNINGS}
+{$I KOLDEF.inc}
+
+interface
+
+uses Windows, ActiveX, KOL, err {$IFDEF _D6orHigher}, Variants {$ENDIF};
+
+type
+{ Forward declarations }
+
+ TComObjectFactory = class;
+
+{ COM server abstract base class }
+
+ TComServerObject = class(TObject)
+ protected
+ function CountObject(Created: Boolean): Integer; virtual; abstract;
+ function CountFactory(Created: Boolean): Integer; virtual; abstract;
+ function GetHelpFileName: AnsiString; virtual; abstract;
+ function GetServerFileName: AnsiString; virtual; abstract;
+ function GetServerKey: AnsiString; virtual; abstract;
+ function GetServerName: AnsiString; virtual; abstract;
+ function GetStartSuspended: Boolean; virtual; abstract;
+ function GetTypeLib: ITypeLib; virtual; abstract;
+ procedure SetHelpFileName(const Value: AnsiString); virtual; abstract;
+ public
+ property HelpFileName: AnsiString read GetHelpFileName write SetHelpFileName;
+ property ServerFileName: AnsiString read GetServerFileName;
+ property ServerKey: AnsiString read GetServerKey;
+ property ServerName: AnsiString read GetServerName;
+ property TypeLib: ITypeLib read GetTypeLib;
+ property StartSuspended: Boolean read GetStartSuspended;
+ end;
+
+
+{ TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain
+ read access to a resource shared among threads while still providing complete
+ exclusivity to callers needing write access to the shared resource.
+ (multithread shared reads, single thread exclusive write)
+ Reading is allowed while owning a write lock.
+ Read locks can be promoted to write locks.}
+
+ {$IFNDEF _D2orD3}
+ TActiveThreadRecord = record
+ ThreadID: Integer;
+ RecursionCount: Integer;
+ end;
+ TActiveThreadArray = array of TActiveThreadRecord;
+
+ TMultiReadExclusiveWriteSynchronizer = class
+ private
+ FLock: TRTLCriticalSection;
+ FReadExit: THandle;
+ FCount: Integer;
+ FSaveReadCount: Integer;
+ FActiveThreads: TActiveThreadArray;
+ FWriteRequestorID: Integer;
+ FReallocFlag: Integer;
+ FWriting: Boolean;
+ function WriterIsOnlyReader: Boolean;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure BeginRead;
+ procedure EndRead;
+ procedure BeginWrite;
+ procedure EndWrite;
+ end;
+ {$ENDIF}
+
+{ COM class manager }
+
+ TFactoryProc = procedure(Factory: TComObjectFactory) of object;
+
+ TComClassManager = class(TObject)
+ private
+ FFactoryList: TComObjectFactory;
+ {$IFNDEF _D2orD3}
+ FLock: TMultiReadExclusiveWriteSynchronizer;
+ {$ENDIF}
+ procedure AddObjectFactory(Factory: TComObjectFactory);
+ procedure RemoveObjectFactory(Factory: TComObjectFactory);
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure ForEachFactory(ComServer: TComServerObject;
+ FactoryProc: TFactoryProc);
+ function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
+ function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
+ end;
+
+{ IServerExceptionHandler }
+{ This interface allows you to report safecall exceptions that occur in a
+ TComObject server to a third party, such as an object that logs errors into
+ the system event log or a server monitor residing on another machine.
+ Obtain an interface from the error logger implementation and assign it
+ to your TComObject's ServerExceptionHandler property. Each TComObject
+ instance can have its own server exception handler, or all instances can
+ share the same handler. The server exception handler can override the
+ TComObject's default exception handling by setting Handled to True and
+ assigning an OLE HResult code to the HResult parameter.
+}
+
+ IServerExceptionHandler = interface
+ ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}']
+ procedure OnException(
+ const ServerClass, ExceptionClass, ErrorMessage: WideString;
+ ExceptAddr: Integer; const ErrorIID, ProgID: WideString;
+ var Handled: Integer; var Result: HResult); dispid 2;
+ end;
+
+{ COM object }
+
+ TComObject = class(TObject, IUnknown, ISupportErrorInfo)
+ private
+ FController: Pointer;
+ FFactory: TComObjectFactory;
+ FNonCountedObject: Boolean;
+ FRefCount: Integer;
+ FServerExceptionHandler: IServerExceptionHandler;
+ function GetController: IUnknown;
+ protected
+ { IUnknown }
+ function IUnknown.QueryInterface = ObjQueryInterface;
+ function IUnknown._AddRef = ObjAddRef;
+ function IUnknown._Release = ObjRelease;
+ { IUnknown methods for other interfaces }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ { ISupportErrorInfo }
+ function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
+ public
+ constructor Create;
+ constructor CreateAggregated(const Controller: IUnknown);
+ constructor CreateFromFactory(Factory: TComObjectFactory;
+ const Controller: IUnknown);
+ destructor Destroy; override;
+ procedure Initialize; virtual;
+ function ObjAddRef: Integer; virtual; stdcall;
+ function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+ function ObjRelease: Integer; virtual; stdcall;
+ function SafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer): HResult; override;
+ property Controller: IUnknown read GetController;
+ property Factory: TComObjectFactory read FFactory;
+ property RefCount: Integer read FRefCount;
+ property ServerExceptionHandler: IServerExceptionHandler
+ read FServerExceptionHandler write FServerExceptionHandler;
+ end;
+
+{ COM class }
+
+ TComClass = class of TComObject;
+
+{ Instancing mode for COM classes }
+
+ TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
+
+{ Threading model supported by COM classes }
+
+ TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth);
+
+{ COM object factory }
+
+ {$IFDEF NOWARNINGS}
+ {$WARNINGS OFF}
+ {$ENDIF}
+ TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
+ private
+ FNext: TComObjectFactory;
+ FComServer: TComServerObject;
+ FComClass: TClass;
+ FClassID: TGUID;
+ FClassName: AnsiString;
+ FDescription: AnsiString;
+ FErrorIID: TGUID;
+ FInstancing: TClassInstancing;
+ FLicString: WideString;
+ FRegister: Longint;
+ FShowErrors: Boolean;
+ FSupportsLicensing: Boolean;
+ FThreadingModel: TThreadingModel;
+ protected
+ function GetProgID: AnsiString; virtual;
+ function GetLicenseString: WideString; virtual;
+ function HasMachineLicense: Boolean; virtual;
+ function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ { IClassFactory }
+ function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
+ out Obj): HResult; stdcall;
+ function LockServer(fLock: BOOL): HResult; stdcall;
+ { IClassFactory2 }
+ function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
+ function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
+ function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
+ const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
+ public
+ constructor Create(ComServer: TComServerObject; ComClass: TComClass;
+ const ClassID: TGUID; const ClassName, Description: AnsiString;
+ Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} );
+ destructor Destroy; override;
+ function CreateComObject(const Controller: IUnknown): TComObject; virtual;
+ procedure RegisterClassObject;
+ procedure UpdateRegistry(Register: Boolean); virtual;
+ property ClassID: TGUID read FClassID;
+ property ClassName: AnsiString read FClassName;
+ property ComClass: TClass read FComClass;
+ property ComServer: TComServerObject read FComServer;
+ property Description: AnsiString read FDescription;
+ property ErrorIID: TGUID read FErrorIID write FErrorIID;
+ property LicString: WideString read FLicString write FLicString;
+ property ProgID: AnsiString read GetProgID;
+ property Instancing: TClassInstancing read FInstancing;
+ property ShowErrors: Boolean read FShowErrors write FShowErrors;
+ property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing;
+ property ThreadingModel: TThreadingModel read FThreadingModel;
+ end;
+ {$IFDEF NOWARNINGS}
+ {$WARNINGS ON}
+ {$ENDIF}
+
+{ COM objects intended to be aggregated / contained }
+
+ TAggregatedObject = class
+ private
+ FController: Pointer;
+ function GetController: IUnknown;
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ public
+ constructor Create(Controller: IUnknown);
+ property Controller: IUnknown read GetController;
+ end;
+
+ TContainedObject = class(TAggregatedObject, IUnknown)
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
+ end;
+
+{ COM object with type information }
+
+ TTypedComObject = class(TComObject, IProvideClassInfo)
+ protected
+ { IProvideClassInfo }
+ function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
+ end;
+
+ TTypedComClass = class of TTypedComObject;
+
+ {$IFDEF NOWARNINGS}
+ {$WARNINGS OFF}
+ {$ENDIF}
+ TTypedComObjectFactory = class(TComObjectFactory)
+ private
+ FClassInfo: ITypeInfo;
+ public
+ constructor Create(ComServer: TComServerObject;
+ TypedComClass: TTypedComClass; const ClassID: TGUID;
+ Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} );
+ function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
+ procedure UpdateRegistry(Register: Boolean); override;
+ property ClassInfo: ITypeInfo read FClassInfo;
+ end;
+ {$IFDEF NOWARNINGS}
+ {$WARNINGS ON}
+ {$ENDIF}
+
+{ OLE Automation object }
+
+ TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object;
+
+ TAutoObjectFactory = class;
+
+ TAutoObject = class(TTypedComObject, IDispatch)
+ private
+ FEventSink: IUnknown;
+ FAutoFactory: TAutoObjectFactory;
+ protected
+ { IDispatch }
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
+ function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
+ { Other methods }
+ procedure EventConnect(const Sink: IUnknown; Connecting: Boolean);
+ procedure EventSinkChanged(const EventSink: IUnknown); virtual;
+ property AutoFactory: TAutoObjectFactory read FAutoFactory;
+ property EventSink: IUnknown read FEventSink write FEventSink;
+ public
+ procedure Initialize; override;
+ end;
+
+{ OLE Automation class }
+
+ TAutoClass = class of TAutoObject;
+
+{ OLE Automation object factory }
+
+ TAutoObjectFactory = class(TTypedComObjectFactory)
+ private
+ FDispTypeInfo: ITypeInfo;
+ FDispIntfEntry: PInterfaceEntry;
+ FEventIID: TGUID;
+ FEventTypeInfo: ITypeInfo;
+ public
+ constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
+ const ClassID: TGUID; Instancing: TClassInstancing;
+ ThreadingModel: TThreadingModel {= tmSingle} );
+ function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
+ property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
+ property DispTypeInfo: ITypeInfo read FDispTypeInfo;
+ property EventIID: TGUID read FEventIID;
+ property EventTypeInfo: ITypeInfo read FEventTypeInfo;
+ end;
+
+ TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
+ private
+ FDispTypeInfo: ITypeInfo;
+ FDispIntfEntry: PInterfaceEntry;
+ FDispIID: TGUID;
+ protected
+ { IDispatch }
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+ function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+ { ISupportErrorInfo }
+ function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
+ public
+ constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
+ function SafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer): HResult; override;
+ property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
+ property DispTypeInfo: ITypeInfo read FDispTypeInfo;
+ property DispIID: TGUID read FDispIID;
+ end;
+
+{ OLE exception classes }
+
+ EOleError = Exception; // class(Exception);
+
+ EOleSysError = EOleError; { class(EOleError)
+ private
+ FErrorCode: HRESULT;
+ public
+ constructor Create(const Message: AnsiString; ErrorCode: HRESULT;
+ HelpContext: Integer);
+ property ErrorCode: HRESULT read FErrorCode write FErrorCode;
+ end;}
+
+ EOleException = EOleSysError; { class(EOleSysError)
+ private
+ FSource: AnsiString;
+ FHelpFile: AnsiString;
+ public
+ constructor Create(const Message: AnsiString; ErrorCode: HRESULT;
+ const Source, HelpFile: AnsiString; HelpContext: Integer);
+ property HelpFile: AnsiString read FHelpFile write FHelpFile;
+ property Source: AnsiString read FSource write FSource;
+ end;}
+
+ EOleRegistrationError = EOleError; { class(EOleError);}
+
+ { Dispatch call descriptor }
+
+ PCallDesc = ^TCallDesc;
+ TCallDesc = packed record
+ CallType: Byte;
+ ArgCount: Byte;
+ NamedArgCount: Byte;
+ ArgTypes: array[0..255] of Byte;
+ end;
+
+ PDispDesc = ^TDispDesc;
+ TDispDesc = packed record
+ DispID: Integer;
+ ResType: Byte;
+ CallDesc: TCallDesc;
+ end;
+
+procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
+ DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
+procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
+
+{function HandleSafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
+ HelpFileName: WideString): HResult;}
+
+function CreateComObject(const ClassID: TGUID): IUnknown;
+function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
+function CreateOleObject(const ClassName: AnsiString): IDispatch;
+function GetActiveOleObject(const ClassName: AnsiString): IDispatch;
+
+procedure OleError(ErrorCode: HResult);
+procedure OleCheck(Result: HResult);
+
+function StringToGUID(const S: AnsiString): TGUID;
+function GUIDToString(const ClassID: TGUID): AnsiString;
+
+function ProgIDToClassID(const ProgID: AnsiString): TGUID;
+function ClassIDToProgID(const ClassID: TGUID): AnsiString;
+
+procedure CreateRegKey(const Key, ValueName, Value: KOLstring);
+procedure DeleteRegKey(const Key: KOLstring);
+function GetRegStringValue(const Key, ValueName: KOLstring): KOLstring;
+
+function StringToLPOLESTR(const Source: KOLstring): POleStr;
+
+procedure RegisterComServer(const DLLName: KOLstring);
+procedure RegisterAsService(const ClassID, ServiceName: KOLstring);
+
+function CreateClassID: KOLstring;
+
+procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
+ const Sink: IUnknown; var Connection: Longint);
+procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
+ var Connection: Longint);
+
+type
+ TCoCreateInstanceExProc = function (const clsid: TCLSID;
+ unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
+ dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
+ TCoInitializeExProc = function (pvReserved: Pointer;
+ coInit: Longint): HResult; stdcall;
+ TCoAddRefServerProcessProc = function :Longint; stdcall;
+ TCoReleaseServerProcessProc = function :Longint; stdcall;
+ TCoResumeClassObjectsProc = function :HResult; stdcall;
+ TCoSuspendClassObjectsProc = function :HResult; stdcall;
+
+// COM functions that are only available on DCOM updated OSs
+// These pointers may be nil on Win95 or Win NT 3.51 systems
+var
+ CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
+ CoInitializeEx: TCoInitializeExProc = nil;
+ CoAddRefServerProcess: TCoAddRefServerProcessProc = nil;
+ CoReleaseServerProcess: TCoReleaseServerProcessProc = nil;
+ CoResumeClassObjects: TCoResumeClassObjectsProc = nil;
+ CoSuspendClassObjects: TCoSuspendClassObjectsProc = nil;
+
+
+{ CoInitFlags determines the COM threading model of the application or current
+ thread. This bitflag value is passed to CoInitializeEx in ComServ initialization.
+ Assign COINIT_APARTMENTTHREADED or COINIT_MULTITHREADED to this variable before
+ Application.Initialize is called by the project source file to select a
+ threading model. Other CoInitializeEx flags (such as COINIT_SPEED_OVER_MEMORY)
+ can be OR'd in also. }
+var
+ CoInitFlags: Integer = -1; // defaults to no threading model, call CoInitialize()
+
+function ComClassManager: TComClassManager;
+
+const
+ GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';
+
+implementation
+
+resourcestring
+ SCreateRegKeyError = 'Error creating system registry entry';
+ SOleError = 'OLE error %.8x';
+ SObjectFactoryMissing = 'Object factory for class %s missing';
+ STypeInfoMissing = 'Type information missing for class %s';
+ SBadTypeInfo = 'Incorrect type information for class %s';
+ SDispIntfMissing = 'Dispatch interface missing from class %s';
+ SNoMethod = 'Method ''%s'' not supported by automation object';
+ SVarNotObject = 'Variant does not reference an automation object';
+ SDCOMNotInstalled = 'DCOM not installed';
+ SDAXError = 'DAX Error';
+
+ SAutomationWarning = 'COM Server Warning';
+ SNoCloseActiveServer1 = 'There are still active COM objects in this ' +
+ 'application. One or more clients may have references to these objects, ' +
+ 'so manually closing ';
+ SNoCloseActiveServer2 = 'this application may cause those client ' +
+ 'application(s) to fail.'#13#10#13#10'Are you sure you want to close this ' +
+ 'application?';
+
+var
+ OleUninitializing: Boolean;
+
+{ Handle a safe call exception }
+
+{function HandleSafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
+ HelpFileName: WideString): HResult;
+var
+ E: TObject;
+ CreateError: ICreateErrorInfo;
+ ErrorInfo: IErrorInfo;
+begin
+ Result := E_UNEXPECTED;
+ E := ExceptObject;
+ if Succeeded(CreateErrorInfo(CreateError)) then
+ begin
+ CreateError.SetGUID(ErrorIID);
+ if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID));
+ if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName));
+ if E is Exception then
+ begin
+ CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
+ CreateError.SetHelpContext(Exception(E).HelpContext);
+ if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
+ Result := EOleSysError(E).ErrorCode;
+ end;
+ if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
+ SetErrorInfo(0, ErrorInfo);
+ end;
+end;}
+
+{ TDispatchSilencer }
+
+type
+ TDispatchSilencer = class(TInterfacedObject, IUnknown, IDispatch)
+ private
+ Dispatch: IDispatch;
+ DispIntfIID: TGUID;
+ public
+ constructor Create(ADispatch: IUnknown; const ADispIntfIID: TGUID);
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ { IDispatch }
+ function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+ end;
+
+constructor TDispatchSilencer.Create(ADispatch: IUnknown;
+ const ADispIntfIID: TGUID);
+begin
+ inherited Create;
+ DispIntfIID := ADispIntfIID;
+ OleCheck(ADispatch.QueryInterface(ADispIntfIID, Dispatch));
+end;
+
+function TDispatchSilencer.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ Result := inherited QueryInterface(IID, Obj);
+ if Result = E_NOINTERFACE then
+ if IsEqualGUID(IID, DispIntfIID) then
+ begin
+ IDispatch(Obj) := Self;
+ Result := S_OK;
+ end
+ else
+ Result := Dispatch.QueryInterface(IID, Obj);
+end;
+
+function TDispatchSilencer.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Result := Dispatch.GetTypeInfoCount(Count);
+end;
+
+function TDispatchSilencer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
+begin
+ Result := Dispatch.GetTypeInfo(Index, LocaleID, TypeInfo);
+end;
+
+function TDispatchSilencer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := Dispatch.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
+end;
+
+function TDispatchSilencer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
+begin
+ { Ignore error since some containers, such as Internet Explorer 3.0x, will
+ return error when the method was not handled, or scripting errors occur }
+ Dispatch.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo,
+ ArgErr);
+ Result := S_OK;
+end;
+
+{$IFNDEF _D2orD3}
+{ TMultiReadExclusiveWriteSynchronizer }
+
+constructor TMultiReadExclusiveWriteSynchronizer.Create;
+begin
+ inherited Create;
+ InitializeCriticalSection(FLock);
+ FReadExit := CreateEvent(nil, True, True, nil); // manual reset, start signaled
+ SetLength(FActiveThreads, 4);
+end;
+
+destructor TMultiReadExclusiveWriteSynchronizer.Destroy;
+begin
+ BeginWrite;
+ inherited Destroy;
+ CloseHandle(FReadExit);
+ DeleteCriticalSection(FLock);
+end;
+
+function TMultiReadExclusiveWriteSynchronizer.WriterIsOnlyReader: Boolean;
+var
+ I, Len: Integer;
+begin
+ Result := False;
+ if FWriteRequestorID = 0 then Exit;
+ // We know a writer is waiting for entry with the FLock locked,
+ // so FActiveThreads is stable - no BeginRead could be resizing it now
+ I := 0;
+ Len := High(FActiveThreads);
+ while (I < Len) and
+ ((FActiveThreads[I].ThreadID = 0) or (FActiveThreads[I].ThreadID = FWriteRequestorID)) do
+ Inc(I);
+ Result := I >= Len;
+end;
+
+procedure TMultiReadExclusiveWriteSynchronizer.BeginWrite;
+begin
+ EnterCriticalSection(FLock); // Block new read or write ops from starting
+ if not FWriting then
+ begin
+ FWriteRequestorID := GetCurrentThreadID; // Indicate that writer is waiting for entry
+ if not WriterIsOnlyReader then // See if any other thread is reading
+ WaitForSingleObject(FReadExit, INFINITE); // Wait for current readers to finish
+ FSaveReadCount := FCount; // record prior read recursions for this thread
+ FCount := 0;
+ FWriteRequestorID := 0;
+ FWriting := True;
+ end;
+ Inc(FCount); // allow read recursions during write without signalling FReadExit event
+end;
+
+procedure TMultiReadExclusiveWriteSynchronizer.EndWrite;
+begin
+ Dec(FCount);
+ if FCount = 0 then
+ begin
+ FCount := FSaveReadCount; // restore read recursion count
+ FSaveReadCount := 0;
+ FWriting := False;
+ end;
+ LeaveCriticalSection(FLock);
+end;
+
+procedure TMultiReadExclusiveWriteSynchronizer.BeginRead;
+var
+ I: Integer;
+ ThreadID: Integer;
+ ZeroSlot: Integer;
+ AlreadyInRead: Boolean;
+begin
+ ThreadID := GetCurrentThreadID;
+ // First, do a lightweight check to see if this thread already has a read lock
+ while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0);
+ try // FActiveThreads array is now stable
+ I := 0;
+ while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do
+ Inc(I);
+ AlreadyInRead := I < High(FActiveThreads);
+ if AlreadyInRead then // This thread already has a read lock
+ begin // Don't grab FLock, since that could deadlock with
+ if not FWriting then // a waiting BeginWrite
+ begin // Bump up ref counts and exit
+ InterlockedIncrement(FCount);
+ Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
+ end;
+ end
+ finally
+ FReallocFlag := 0;
+ end;
+ if not AlreadyInRead then
+ begin // Ok, we don't already have a lock, so do the hard work of making one
+ EnterCriticalSection(FLock);
+ try
+ if not FWriting then
+ begin
+ // This will call ResetEvent more than necessary on win95, but still work
+ if InterlockedIncrement(FCount) = 1 then
+ ResetEvent(FReadExit); // Make writer wait until all readers are finished.
+ I := 0; // scan for empty slot in activethreads list
+ ZeroSlot := -1;
+ while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do
+ begin
+ if (FActiveThreads[I].ThreadID = 0) and (ZeroSlot < 0) then ZeroSlot := I;
+ Inc(I);
+ end;
+ if I >= High(FActiveThreads) then // didn't find our threadid slot
+ begin
+ if ZeroSlot < 0 then // no slots available. Grow array to make room
+ begin // spin loop. wait for EndRead to put zero back into FReallocFlag
+ while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0);
+ try
+ SetLength(FActiveThreads, High(FActiveThreads) + 3);
+ finally
+ FReallocFlag := 0;
+ end;
+ end
+ else // use an empty slot
+ I := ZeroSlot;
+ // no concurrency issue here. We're the only thread interested in this record.
+ FActiveThreads[I].ThreadID := ThreadID;
+ FActiveThreads[I].RecursionCount := 1;
+ end
+ else // found our threadid slot.
+ Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
+ end;
+ finally
+ LeaveCriticalSection(FLock);
+ end;
+ end;
+end;
+
+procedure TMultiReadExclusiveWriteSynchronizer.EndRead;
+var
+ I, ThreadID, Len: Integer;
+begin
+ if not FWriting then
+ begin
+ // Remove our threadid from the list of active threads
+ I := 0;
+ ThreadID := GetCurrentThreadID;
+ // wait for BeginRead to finish any pending realloc of FActiveThreads
+ while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0);
+ try
+ Len := High(FActiveThreads);
+ while (I < Len) and (FActiveThreads[I].ThreadID <> ThreadID) do Inc(I);
+ assert(I < Len);
+ // no concurrency issues here. We're the only thread interested in this record.
+ Dec(FActiveThreads[I].RecursionCount); // threadsafe = unique to threadid
+ if FActiveThreads[I].RecursionCount = 0 then
+ FActiveThreads[I].ThreadID := 0; // must do this last!
+ finally
+ FReallocFlag := 0;
+ end;
+ if (InterlockedDecrement(FCount) = 0) or WriterIsOnlyReader then
+ SetEvent(FReadExit); // release next writer
+ end;
+end;
+
+procedure FreeAndNil(var Obj);
+var
+ P: TObject;
+begin
+ P := TObject(Obj);
+ TObject(Obj) := nil; // clear the reference before destroying the object
+ P.Free;
+end;
+{$ENDIF}
+
+{ TComClassManager }
+constructor TComClassManager.Create;
+begin
+ inherited Create;
+ {$IFNDEF _D2orD3}
+ FLock := TMultiReadExclusiveWriteSynchronizer.Create;
+ {$ENDIF}
+end;
+
+destructor TComClassManager.Destroy;
+begin
+ {$IFNDEF _D2orD3}
+ FLock.Free;
+ {$ENDIF}
+ inherited Destroy;
+end;
+
+procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory);
+begin
+ {$IFNDEF _D2orD3}
+ FLock.BeginWrite;
+ try
+ {$ENDIF}
+ Factory.FNext := FFactoryList;
+ FFactoryList := Factory;
+ {$IFNDEF _D2orD3}
+ finally
+ FLock.EndWrite;
+ end;
+ {$ENDIF}
+end;
+
+procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
+ FactoryProc: TFactoryProc);
+var
+ Factory, Next: TComObjectFactory;
+begin
+ {$IFNDEF _D2orD3}
+ FLock.BeginWrite; // FactoryProc could add or delete factories from list
+ try
+ {$ENDIF}
+ Factory := FFactoryList;
+ while Factory <> nil do
+ begin
+ Next := Factory.FNext;
+ if Factory.ComServer = ComServer then FactoryProc(Factory);
+ Factory := Next;
+ end;
+ {$IFNDEF _D2orD3}
+ finally
+ FLock.EndWrite;
+ end;
+ {$ENDIF}
+end;
+
+function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
+begin
+ {$IFNDEF _D2orD3}
+ FLock.BeginRead;
+ try
+ {$ENDIF}
+ Result := FFactoryList;
+ while Result <> nil do
+ begin
+ if Result.ComClass = ComClass then Exit;
+ Result := Result.FNext;
+ end;
+ raise EOleError.CreateResFmt(e_Ole, Integer( @SObjectFactoryMissing ), [ComClass.ClassName]);
+ {$IFNDEF _D2orD3}
+ finally
+ FLock.EndRead;
+ end;
+ {$ENDIF}
+end;
+
+function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
+begin
+ {$IFNDEF _D2orD3}
+ FLock.BeginRead;
+ try
+ {$ENDIF}
+ Result := FFactoryList;
+ while Result <> nil do
+ begin
+ if IsEqualGUID(Result.ClassID, ClassID) then Exit;
+ Result := Result.FNext;
+ end;
+ {$IFNDEF _D2orD3}
+ finally
+ FLock.EndRead;
+ end;
+ {$ENDIF}
+end;
+
+procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory);
+var
+ F, P: TComObjectFactory;
+begin
+ {$IFNDEF _D2orD3}
+ FLock.BeginWrite;
+ try
+ {$ENDIF}
+ P := nil;
+ F := FFactoryList;
+ while F <> nil do
+ begin
+ if F = Factory then
+ begin
+ if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext;
+ Exit;
+ end;
+ P := F;
+ F := F.FNext;
+ end;
+ {$IFNDEF _D2orD3}
+ finally
+ FLock.EndWrite;
+ end;
+ {$ENDIF}
+end;
+
+{ TComObject }
+
+constructor TComObject.Create;
+begin
+ FNonCountedObject := True;
+ CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil);
+end;
+
+constructor TComObject.CreateAggregated(const Controller: IUnknown);
+begin
+ FNonCountedObject := True;
+ CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller);
+end;
+
+constructor TComObject.CreateFromFactory(Factory: TComObjectFactory;
+ const Controller: IUnknown);
+begin
+ FRefCount := 1;
+ FFactory := Factory;
+ FController := Pointer(Controller);
+ if not FNonCountedObject then FFactory.ComServer.CountObject(True);
+ Initialize;
+ Dec(FRefCount);
+end;
+
+destructor TComObject.Destroy;
+begin
+ if not OleUninitializing then
+ begin
+ if (FFactory <> nil) and not FNonCountedObject then
+ FFactory.ComServer.CountObject(False);
+ if FRefCount > 0 then CoDisconnectObject(Self, 0);
+ end;
+end;
+
+function TComObject.GetController: IUnknown;
+begin
+ Result := IUnknown(FController);
+end;
+
+procedure TComObject.Initialize;
+begin
+end;
+
+function TComObject.SafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer): HResult;
+var
+ Msg: AnsiString;
+ Handled: Integer;
+begin
+ Handled := 0;
+ if ServerExceptionHandler <> nil then
+ begin
+ if ExceptObject is Exception then
+ Msg := Exception(ExceptObject).Message;
+ Result := 0;
+ ServerExceptionHandler.OnException(ClassName,
+ ExceptObject.ClassName, Msg, Integer(ExceptAddr),
+ WideString(GUIDToString(FFactory.ErrorIID)),
+ FFactory.ProgID, Handled, Result);
+ end;
+ if Handled = 0 then
+ {Result := HandleSafeCallException(ExceptObject, ExceptAddr,
+ FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);}
+end;
+
+{ TComObject.IUnknown }
+
+function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
+end;
+
+function TComObject.ObjAddRef: Integer;
+begin
+ Result := InterlockedIncrement(FRefCount);
+end;
+
+function TComObject.ObjRelease: Integer;
+begin
+ // InterlockedDecrement returns only 0 or 1 on Win95 and NT 3.51
+ // returns actual result on NT 4.0
+ Result := InterlockedDecrement(FRefCount);
+ if Result = 0 then Destroy;
+end;
+
+{ TComObject.IUnknown for other interfaces }
+
+function TComObject.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if FController <> nil then
+ Result := IUnknown(FController).QueryInterface(IID, Obj) else
+ Result := ObjQueryInterface(IID, Obj);
+end;
+
+function TComObject._AddRef: Integer;
+begin
+ if FController <> nil then
+ Result := IUnknown(FController)._AddRef else
+ Result := ObjAddRef;
+end;
+
+function TComObject._Release: Integer;
+begin
+ if FController <> nil then
+ Result := IUnknown(FController)._Release else
+ Result := ObjRelease;
+end;
+
+{ TComObject.ISupportErrorInfo }
+
+function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
+begin
+ if GetInterfaceEntry(iid) <> nil then
+ Result := S_OK else
+ Result := S_FALSE;
+end;
+
+{ TComObjectFactory }
+
+constructor TComObjectFactory.Create(ComServer: TComServerObject;
+ ComClass: TComClass; const ClassID: TGUID; const ClassName,
+ Description: AnsiString; Instancing: TClassInstancing;
+ ThreadingModel: TThreadingModel);
+begin
+ IsMultiThread := IsMultiThread or (ThreadingModel <> tmSingle);
+ if ThreadingModel in [tmFree, tmBoth] then
+ CoInitFlags := COINIT_MULTITHREADED else
+ if (ThreadingModel = tmApartment) and (CoInitFlags <> COINIT_MULTITHREADED) then
+ CoInitFlags := COINIT_APARTMENTTHREADED;
+ ComClassManager.AddObjectFactory(Self);
+ FComServer := ComServer;
+ FComClass := ComClass;
+ FClassID := ClassID;
+ FClassName := ClassName;
+ FDescription := Description;
+ FInstancing := Instancing;
+ FErrorIID := IUnknown;
+ FShowErrors := True;
+ FThreadingModel := ThreadingModel;
+ FRegister := -1;
+end;
+
+destructor TComObjectFactory.Destroy;
+begin
+ if FRegister <> -1 then CoRevokeClassObject(FRegister);
+ ComClassManager.RemoveObjectFactory(Self);
+end;
+
+function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
+begin
+ Result := TComClass(FComClass).CreateFromFactory(Self, Controller);
+end;
+
+function TComObjectFactory.GetProgID: AnsiString;
+begin
+ if FClassName <> '' then
+ Result := FComServer.ServerName + '.' + FClassName else
+ Result := '';
+end;
+
+procedure TComObjectFactory.RegisterClassObject;
+const
+ RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = (
+ REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
+ SuspendedFlag: array[Boolean] of Integer = (0, REGCLS_SUSPENDED);
+begin
+ if FInstancing <> ciInternal then
+ OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
+ RegFlags[FInstancing] or SuspendedFlag[FComServer.StartSuspended], FRegister));
+end;
+
+procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
+const
+ ThreadStrs: array[TThreadingModel] of AnsiString =
+ ('', 'Apartment', 'Free', 'Both');
+var
+ ClassID, ProgID, ServerKeyName, ShortFileName: AnsiString;
+begin
+ if FInstancing = ciInternal then Exit;
+ ClassID := GUIDToString(FClassID);
+ ProgID := GetProgID;
+ ServerKeyName := 'CLSID\' + ClassID + '\' + FComServer.ServerKey;
+ if Register then
+ begin
+ CreateRegKey('CLSID\' + ClassID, '', Description);
+ ShortFileName := FComServer.ServerFileName;
+ if {Ansi}Pos(' ', ShortFileName) <> 0 then
+ ShortFileName := ExtractShortPathName(ShortFileName);
+ CreateRegKey(ServerKeyName, '', ShortFileName);
+ if (FThreadingModel <> tmSingle) and IsLibrary then
+ CreateRegKey(ServerKeyName, 'ThreadingModel', ThreadStrs[FThreadingModel]);
+ if ProgID <> '' then
+ begin
+ CreateRegKey(ProgID, '', Description);
+ CreateRegKey(ProgID + '\Clsid', '', ClassID);
+ CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID);
+ end;
+ end else
+ begin
+ if ProgID <> '' then
+ begin
+ DeleteRegKey('CLSID\' + ClassID + '\ProgID');
+ DeleteRegKey(ProgID + '\Clsid');
+ DeleteRegKey(ProgID);
+ end;
+ DeleteRegKey(ServerKeyName);
+ DeleteRegKey('CLSID\' + ClassID);
+ end;
+end;
+
+function TComObjectFactory.GetLicenseString: WideString;
+begin
+ if FSupportsLicensing then Result := FLicString
+ else Result := '';
+end;
+
+function TComObjectFactory.HasMachineLicense: Boolean;
+begin
+ Result := True;
+end;
+
+function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean;
+begin
+ Result := AnsiCompareText(LicStr, FLicString) = 0;
+end;
+
+{ TComObjectFactory.IUnknown }
+
+function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
+end;
+
+function TComObjectFactory._AddRef: Integer;
+begin
+ Result := ComServer.CountFactory(True);
+end;
+
+function TComObjectFactory._Release: Integer;
+begin
+ Result := ComServer.CountFactory(False);
+end;
+
+{ TComObjectFactory.IClassFactory }
+
+function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
+ const IID: TGUID; out Obj): HResult;
+begin
+ Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj);
+end;
+
+function TComObjectFactory.LockServer(fLock: BOOL): HResult;
+begin
+ Result := CoLockObjectExternal(Self, fLock, True);
+ // Keep com server alive until this class factory is unlocked
+ ComServer.CountObject(fLock);
+end;
+
+{ TComObjectFactory.IClassFactory2 }
+
+function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult;
+begin
+ Result := S_OK;
+ try
+ with licInfo do
+ begin
+ cbLicInfo := SizeOf(licInfo);
+ fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> '');
+ fLicVerified := (not FSupportsLicensing) or HasMachineLicense;
+ end;
+ except
+ Result := E_UNEXPECTED;
+ end;
+end;
+
+function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult;
+begin
+ // Can't give away a license key on an unlicensed machine
+ if not HasMachineLicense then
+ begin
+ Result := CLASS_E_NOTLICENSED;
+ Exit;
+ end;
+ bstrKey := FLicString;
+ Result := NOERROR;
+end;
+
+function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown;
+ const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString;
+ out vObject): HResult; stdcall;
+var
+ ComObject: TComObject;
+begin
+ // We can't write to a nil pointer. Duh.
+ if @vObject = nil then
+ begin
+ Result := E_POINTER;
+ Exit;
+ end;
+ // In case of failure, make sure we return at least a nil interface.
+ Pointer(vObject) := nil;
+ // Check for licensing.
+ if FSupportsLicensing and
+ ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or
+ ((bstrKey = '') and (not HasMachineLicense)) then
+ begin
+ Result := CLASS_E_NOTLICENSED;
+ Exit;
+ end;
+ // We can only aggregate if they are requesting our IUnknown.
+ if (unkOuter <> nil) and not (IsEqualIID(iid, IUnknown)) then
+ begin
+ Result := CLASS_E_NOAGGREGATION;
+ Exit;
+ end;
+ try
+ ComObject := CreateComObject(UnkOuter);
+ except
+ if FShowErrors and (ExceptObject is Exception) then
+ with Exception(ExceptObject) do
+ begin
+ {if (Message <> '') and (AnsiLastChar(Message) > '.') then
+ Message := Message + '.';}
+ MessageBox(0, PKOLChar(Message), PKOLChar(KOLString( SDAXError )), MB_OK or MB_ICONSTOP or
+ MB_SETFOREGROUND);
+ end;
+ Result := E_UNEXPECTED;
+ Exit;
+ end;
+ Result := ComObject.ObjQueryInterface(IID, vObject);
+ if ComObject.RefCount = 0 then ComObject.Free;
+end;
+
+{ TAggregatedObject }
+
+constructor TAggregatedObject.Create(Controller: IUnknown);
+begin
+ FController := Pointer(Controller);
+end;
+
+function TAggregatedObject.GetController: IUnknown;
+begin
+ Result := IUnknown(FController);
+end;
+
+{ TAggregatedObject.IUnknown }
+
+function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ Result := IUnknown(FController).QueryInterface(IID, Obj);
+end;
+
+function TAggregatedObject._AddRef: Integer;
+begin
+ Result := IUnknown(FController)._AddRef;
+end;
+
+function TAggregatedObject._Release: Integer; stdcall;
+begin
+ Result := IUnknown(FController)._Release;
+end;
+
+{ TContainedObject.IUnknown }
+
+function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
+end;
+
+{ TTypedComObject.IProvideClassInfo }
+
+function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
+begin
+ TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo;
+ Result := S_OK;
+end;
+
+{ TTypedComObjectFactory }
+
+constructor TTypedComObjectFactory.Create(ComServer: TComServerObject;
+ TypedComClass: TTypedComClass; const ClassID: TGUID;
+ Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
+var
+ ClassName, Description: WideString;
+begin
+ if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then
+ raise EOleError.CreateResFmt(e_Ole, Integer(@STypeInfoMissing), [TypedComClass.ClassName]);
+ OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName,
+ @Description, nil, nil));
+ inherited Create(ComServer, TypedComClass, ClassID,
+ ClassName, Description, Instancing, ThreadingModel);
+end;
+
+function TTypedComObjectFactory.GetInterfaceTypeInfo(
+ TypeFlags: Integer): ITypeInfo;
+const
+ FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE;
+var
+ ClassAttr: PTypeAttr;
+ I, TypeInfoCount, Flags: Integer;
+ RefType: HRefType;
+begin
+ OleCheck(FClassInfo.GetTypeAttr(ClassAttr));
+ TypeInfoCount := ClassAttr^.cImplTypes;
+ ClassInfo.ReleaseTypeAttr(ClassAttr);
+ for I := 0 to TypeInfoCount - 1 do
+ begin
+ OleCheck(ClassInfo.GetImplTypeFlags(I, Flags));
+ if Flags and FlagsMask = TypeFlags then
+ begin
+ OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType));
+ OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
+ Exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
+var
+ ClassKey: AnsiString;
+ TypeLib: ITypeLib;
+ TLibAttr: PTLibAttr;
+begin
+ ClassKey := 'CLSID\' + GUIDToString(FClassID);
+ if Register then
+ begin
+ inherited UpdateRegistry(Register);
+ TypeLib := FComServer.TypeLib;
+ OleCheck(TypeLib.GetLibAttr(TLibAttr));
+ try
+ CreateRegKey(ClassKey + '\Version', '', Format('%d.%d',
+ [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum]));
+ CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid));
+ finally
+ TypeLib.ReleaseTLibAttr(TLibAttr);
+ end;
+ end else
+ begin
+ DeleteRegKey(ClassKey + '\TypeLib');
+ DeleteRegKey(ClassKey + '\Version');
+ inherited UpdateRegistry(Register);
+ end;
+end;
+
+{ TAutoObject }
+
+procedure TAutoObject.EventConnect(const Sink: IUnknown;
+ Connecting: Boolean);
+begin
+ if Connecting then
+ begin
+ OleCheck(Sink.QueryInterface(FAutoFactory.FEventIID, FEventSink));
+ EventSinkChanged(TDispatchSilencer.Create(Sink, FAutoFactory.FEventIID));
+ end
+ else
+ begin
+ FEventSink := nil;
+ EventSinkChanged(nil);
+ end;
+end;
+
+procedure TAutoObject.EventSinkChanged(const EventSink: IUnknown);
+begin
+end;
+
+procedure TAutoObject.Initialize;
+begin
+ FAutoFactory := Factory as TAutoObjectFactory;
+ inherited Initialize;
+end;
+
+{ TAutoObject.IDispatch }
+
+function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := DispGetIDsOfNames(FAutoFactory.DispTypeInfo,
+ Names, NameCount, DispIDs);
+end;
+
+function TAutoObject.GetTypeInfo(Index, LocaleID: Integer;
+ out TypeInfo): HResult;
+begin
+ Pointer(TypeInfo) := nil;
+ if Index <> 0 then
+ begin
+ Result := DISP_E_BADINDEX;
+ Exit;
+ end;
+ ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo;
+ Result := S_OK;
+end;
+
+function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Count := 1;
+ Result := S_OK;
+end;
+
+function TAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
+const
+ INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
+begin
+ if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
+ Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
+ Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
+ DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
+end;
+
+{ TAutoObjectFactory }
+
+constructor TAutoObjectFactory.Create(ComServer: TComServerObject;
+ AutoClass: TAutoClass; const ClassID: TGUID;
+ Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
+var
+ TypeAttr: PTypeAttr;
+begin
+ inherited Create(ComServer, AutoClass, ClassID, Instancing, ThreadingModel);
+ FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
+ if FDispTypeInfo = nil then
+ raise EOleError.CreateResFmt(e_Ole, Integer(@SBadTypeInfo), [AutoClass.ClassName]);
+ OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr));
+ FDispIntfEntry := GetIntfEntry(TypeAttr^.guid);
+ FDispTypeInfo.ReleaseTypeAttr(TypeAttr);
+ if FDispIntfEntry = nil then
+ raise EOleError.CreateResFmt(e_Ole, Integer(@SDispIntfMissing),
+ [AutoClass.ClassName]);
+ FErrorIID := FDispIntfEntry^.IID;
+ FEventTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT or
+ IMPLTYPEFLAG_FSOURCE);
+ if FEventTypeInfo <> nil then
+ begin
+ OleCheck(FEventTypeInfo.GetTypeAttr(TypeAttr));
+ FEventIID := TypeAttr.guid;
+ FEventTypeInfo.ReleaseTypeAttr(TypeAttr);
+ end;
+end;
+
+function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
+begin
+ Result := FComClass.GetInterfaceEntry(Guid);
+end;
+
+{ TAutoIntfObject }
+
+constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
+begin
+ inherited Create;
+ OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo));
+ FDispIntfEntry := GetInterfaceEntry(DispIntf);
+end;
+
+{ TAutoIntfObject.IDispatch }
+
+function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs);
+end;
+
+function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer;
+ out TypeInfo): HResult;
+begin
+ Pointer(TypeInfo) := nil;
+ if Index <> 0 then
+ begin
+ Result := DISP_E_BADINDEX;
+ Exit;
+ end;
+ ITypeInfo(TypeInfo) := FDispTypeInfo;
+ Result := S_OK;
+end;
+
+function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Count := 1;
+ Result := S_OK;
+end;
+
+function TAutoIntfObject.Invoke(DispID: Integer; const IID: TGUID;
+ LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+ ArgErr: Pointer): HResult;
+const
+ INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
+begin
+ if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
+ Result := FDispTypeInfo.Invoke(Pointer(Integer(Self) +
+ FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult,
+ ExcepInfo, ArgErr);
+end;
+
+function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
+begin
+ if IsEqualGUID(DispIID, iid) then
+ Result := S_OK else
+ Result := S_FALSE;
+end;
+
+function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
+ ExceptAddr: Pointer): HResult;
+begin
+ Result := 0; { HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', ''); }
+end;
+
+const
+{ Maximum number of dispatch arguments }
+
+ MaxDispArgs = 64; {!!!}
+
+{ Special variant type codes }
+
+ varStrArg = $0048;
+
+{ Parameter type masks }
+
+ atVarMask = $3F;
+ atTypeMask = $7F;
+ atByRef = $80;
+
+{function TrimPunctuation(const S: AnsiString): AnsiString;
+var
+ P: PChar;
+begin
+ Result := S;
+ P := AnsiLastChar(Result);
+ while (Length(Result) > 0) and (P^ in [#0..#32, '.']) do
+ begin
+ SetLength(Result, P - PChar(Result));
+ P := AnsiLastChar(Result);
+ end;
+end;}
+
+{ EOleSysError }
+
+{constructor EOleSysError.Create(const Message: AnsiString;
+ ErrorCode: HRESULT; HelpContext: Integer);
+var
+ S: AnsiString;
+begin
+ S := Message;
+ if S = '' then
+ begin
+ S := SysErrorMessage(ErrorCode);
+ if S = '' then FmtStr(S, SOleError, [ErrorCode]);
+ end;
+ inherited CreateHelp(S, HelpContext);
+ FErrorCode := ErrorCode;
+end;}
+
+{ EOleException }
+
+{constructor EOleException.Create(const Message: AnsiString; ErrorCode: HRESULT;
+ const Source, HelpFile: AnsiString; HelpContext: Integer);
+begin
+ inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext);
+ FSource := Source;
+ FHelpFile := HelpFile;
+end;}
+
+
+{ Raise EOleSysError exception from an error code }
+
+procedure OleError(ErrorCode: HResult);
+begin
+ raise EOleSysError.Create(e_Ole, 'OLE error: ' + Int2Str( ErrorCode ) );
+end;
+
+{ Raise EOleSysError exception if result code indicates an error }
+
+procedure OleCheck(Result: HResult);
+begin
+ if not Succeeded(Result) then OleError(Result);
+end;
+
+{ Convert a AnsiString to a GUID }
+
+function StringToGUID(const S: AnsiString): TGUID;
+begin
+ OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
+end;
+
+{ Convert a GUID to a AnsiString }
+
+function GUIDToString(const ClassID: TGUID): AnsiString;
+var
+ P: PWideChar;
+begin
+ OleCheck(StringFromCLSID(ClassID, P));
+ Result := P;
+ CoTaskMemFree(P);
+end;
+
+{ Convert a programmatic ID to a class ID }
+
+function ProgIDToClassID(const ProgID: AnsiString): TGUID;
+begin
+ OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
+end;
+
+{ Convert a class ID to a programmatic ID }
+
+function ClassIDToProgID(const ClassID: TGUID): AnsiString;
+var
+ P: PWideChar;
+begin
+ OleCheck(ProgIDFromCLSID(ClassID, P));
+ Result := P;
+ CoTaskMemFree(P);
+end;
+
+{ Create registry key }
+
+procedure CreateRegKey(const Key, ValueName, Value: KOLstring);
+var
+ Handle: HKey;
+ Status, Disposition: Integer;
+begin
+ Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PKOLChar(Key), 0, '',
+ REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
+ @Disposition);
+ if Status = 0 then
+ begin
+ Status := RegSetValueEx(Handle, PKOLChar(ValueName), 0, REG_SZ,
+ PKOLChar(Value), Length(Value) + 1);
+ RegCloseKey(Handle);
+ end;
+ if Status <> 0 then raise EOleRegistrationError.CreateResFmt(e_Registry,
+ Integer(@SCreateRegKeyError), [ nil ] );
+end;
+
+{ Delete registry key }
+
+procedure DeleteRegKey(const Key: KOLstring);
+begin
+ RegDeleteKey(HKEY_CLASSES_ROOT, PKOLChar(Key));
+end;
+
+{ Get registry value }
+
+function GetRegStringValue(const Key, ValueName: KOLstring): KOLstring;
+var
+ Size: DWord;
+ RegKey: HKEY;
+begin
+ Result := '';
+ if RegOpenKey(HKEY_CLASSES_ROOT, PKOLChar(Key), RegKey) = ERROR_SUCCESS then
+ try
+ Size := 256;
+ SetLength(Result, Size);
+ if RegQueryValueEx(RegKey, PKOLChar(ValueName), nil, nil, PByte(PKOLChar(Result)), @Size) = ERROR_SUCCESS then
+ SetLength(Result, Size - 1) else
+ Result := '';
+ finally
+ RegCloseKey(RegKey);
+ end;
+end;
+
+function CreateComObject(const ClassID: TGUID): IUnknown;
+begin
+ OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
+ CLSCTX_LOCAL_SERVER, IUnknown, Result));
+end;
+
+function CreateRemoteComObject(const MachineName: WideString;
+ const ClassID: TGUID): IUnknown;
+const
+ LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
+ RemoteFlags = CLSCTX_REMOTE_SERVER;
+var
+ MQI: TMultiQI;
+ ServerInfo: TCoServerInfo;
+ IID_IUnknown: TGuid;
+ Flags, Size: DWORD;
+ LocalMachine: array [0..MAX_COMPUTERNAME_LENGTH] of KOLchar;
+begin
+ if @CoCreateInstanceEx = nil then
+ raise Exception.CreateResFmt(e_Com, Integer(@SDCOMNotInstalled), [nil]);
+ FillChar(ServerInfo, sizeof(ServerInfo), 0);
+ ServerInfo.pwszName := PWideChar(MachineName);
+ IID_IUnknown := IUnknown;
+ MQI.IID := @IID_IUnknown;
+ MQI.itf := nil;
+ MQI.hr := 0;
+ { If a MachineName is specified check to see if it the local machine.
+ If it isn't, do not allow LocalServers to be used. }
+ if Length(MachineName) > 0 then
+ begin
+ Size := Sizeof(LocalMachine); // Win95 is hypersensitive to size
+ if GetComputerName(LocalMachine, Size) and
+ (AnsiCompareText(LocalMachine, MachineName) = 0) then
+ Flags := LocalFlags else
+ Flags := RemoteFlags;
+ end else
+ Flags := LocalFlags;
+ OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @ServerInfo, 1, @MQI));
+ OleCheck(MQI.HR);
+ Result := MQI.itf;
+end;
+
+function CreateOleObject(const ClassName: AnsiString): IDispatch;
+var
+ ClassID: TCLSID;
+begin
+ ClassID := ProgIDToClassID(ClassName);
+ OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
+ CLSCTX_LOCAL_SERVER, IDispatch, Result));
+end;
+
+function GetActiveOleObject(const ClassName: AnsiString): IDispatch;
+var
+ ClassID: TCLSID;
+ Unknown: IUnknown;
+begin
+ ClassID := ProgIDToClassID(ClassName);
+ OleCheck(GetActiveObject(ClassID, nil, Unknown));
+ OleCheck(Unknown.QueryInterface(IDispatch, Result));
+end;
+
+function StringToLPOLESTR(const Source: KOLstring): POleStr;
+var
+ SourceLen: Integer;
+ Buffer: PWideChar;
+begin
+ SourceLen := Length(Source);
+ Buffer := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar));
+ StringToWideChar( Source, Buffer, SourceLen+1 );
+ Result := POleStr( Buffer );
+end;
+
+function CreateClassID: KOLstring;
+var
+ ClassID: TCLSID;
+ P: PWideChar;
+begin
+ CoCreateGuid(ClassID);
+ StringFromCLSID(ClassID, P);
+ Result := P;
+ CoTaskMemFree(P);
+end;
+
+procedure RegisterComServer(const DLLName: KOLstring);
+type
+ TRegProc = function: HResult; stdcall;
+const
+ RegProcName = 'DllRegisterServer'; { Do not localize }
+var
+ Handle: THandle;
+ RegProc: TRegProc;
+begin
+ {$IFDEF _D2orD3}
+ Handle := LoadLibrary( PChar( DLLName ) );
+ {$ELSE}
+ Handle := SafeLoadLibrary(DLLName);
+ {$ENDIF}
+ if Handle <= HINSTANCE_ERROR then
+ raise Exception.CreateFmt( e_Com, '%s: %s', [SysErrorMessage(GetLastError), DLLName]);
+ try
+ RegProc := GetProcAddress(Handle, RegProcName);
+ if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error;
+ finally
+ FreeLibrary(Handle);
+ end;
+end;
+
+procedure RegisterAsService(const ClassID, ServiceName: KOLstring);
+begin
+ CreateRegKey('AppID\' + ClassID, 'LocalService', ServiceName);
+ CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);
+end;
+
+{ Connect an IConnectionPoint interface }
+
+procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
+ const Sink: IUnknown; var Connection: Longint);
+var
+ CPC: IConnectionPointContainer;
+ CP: IConnectionPoint;
+begin
+ Connection := 0;
+ if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
+ if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
+ CP.Advise(Sink, Connection);
+end;
+
+{ Disconnect an IConnectionPoint interface }
+
+procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
+ var Connection: Longint);
+var
+ CPC: IConnectionPointContainer;
+ CP: IConnectionPoint;
+begin
+ if Connection <> 0 then
+ if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
+ if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
+ if Succeeded(CP.Unadvise(Connection)) then Connection := 0;
+end;
+
+procedure LoadComExProcs;
+var
+ Ole32: HModule;
+begin
+ Ole32 := GetModuleHandle('ole32.dll');
+ if Ole32 <> 0 then
+ begin
+ @CoCreateInstanceEx := GetProcAddress(Ole32, 'CoCreateInstanceEx');
+ @CoInitializeEx := GetProcAddress(Ole32, 'CoInitializeEx');
+ @CoAddRefServerProcess := GetProcAddress(Ole32, 'CoAddRefServerProcess');
+ @CoReleaseServerProcess := GetProcAddress(Ole32, 'CoReleaseServerProcess');
+ @CoResumeClassObjects := GetProcAddress(Ole32, 'CoResumeClassObjects');
+ @CoSuspendClassObjects := GetProcAddress(Ole32, 'CoSuspendClassObjects');
+ end;
+end;
+
+procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
+var
+ ErrorInfo: IErrorInfo;
+ Source, Description, HelpFile: WideString;
+ HelpContext: Longint;
+begin
+ HelpContext := 0;
+ if GetErrorInfo(0, ErrorInfo) = S_OK then
+ begin
+ ErrorInfo.GetSource(Source);
+ ErrorInfo.GetDescription(Description);
+ ErrorInfo.GetHelpFile(HelpFile);
+ ErrorInfo.GetHelpContext(HelpContext);
+ end;
+ raise EOleException.Create(e_Ole, Description + Int2Str( ErrorCode ) {, Source,
+ HelpFile, HelpContext} ) at ErrorAddr;
+end;
+
+{ Call Invoke method on the given IDispatch interface using the given
+ call descriptor, dispatch IDs, parameters, and result }
+
+procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
+ DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
+type
+ PVarArg = ^TVarArg;
+ TVarArg = array[0..3] of DWORD;
+ TStringDesc = record
+ BStr: PWideChar;
+ PStr: pAnsiString;
+ end;
+var
+ I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
+ VarFlag: Byte;
+ ParamPtr: ^Integer;
+ ArgPtr, VarPtr: PVarArg;
+ DispParams: TDispParams;
+ ExcepInfo: TExcepInfo;
+ Strings: array[0..MaxDispArgs - 1] of TStringDesc;
+ Args: array[0..MaxDispArgs - 1] of TVarArg;
+begin
+ StrCount := 0;
+ try
+ ArgCount := CallDesc^.ArgCount;
+ if ArgCount <> 0 then
+ begin
+ ParamPtr := Params;
+ ArgPtr := @Args[ArgCount];
+ I := 0;
+ repeat
+ Dec(Integer(ArgPtr), SizeOf(TVarData));
+ ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
+ VarFlag := CallDesc^.ArgTypes[I] and atByRef;
+ if ArgType = varError then
+ begin
+ ArgPtr^[0] := varError;
+ ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND);
+ end else
+ begin
+ if ArgType = varStrArg then
+ begin
+ with Strings[StrCount] do
+ if VarFlag <> 0 then
+ begin
+ BStr := StringToOleStr(pAnsiString(ParamPtr^)^);
+ PStr := pAnsiString(ParamPtr^);
+ ArgPtr^[0] := varOleStr or varByRef;
+ ArgPtr^[2] := Integer(@BStr);
+ end else
+ begin
+ BStr := StringToOleStr(pAnsiString(ParamPtr)^);
+ PStr := nil;
+ ArgPtr^[0] := varOleStr;
+ ArgPtr^[2] := Integer(BStr);
+ end;
+ Inc(StrCount);
+ end else
+ if VarFlag <> 0 then
+ begin
+ if (ArgType = varVariant) and
+ (PVarData(ParamPtr^)^.VType = varString) then
+ VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
+ ArgPtr^[0] := ArgType or varByRef;
+ ArgPtr^[2] := ParamPtr^;
+ end else
+ if ArgType = varVariant then
+ begin
+ if PVarData(ParamPtr)^.VType = varString then
+ begin
+ with Strings[StrCount] do
+ begin
+ BStr := StringToOleStr(AnsiString(PVarData(ParamPtr^)^.VString));
+ PStr := nil;
+ ArgPtr^[0] := varOleStr;
+ ArgPtr^[2] := Integer(BStr);
+ end;
+ Inc(StrCount);
+ end else
+ begin
+ VarPtr := PVarArg(ParamPtr);
+ ArgPtr^[0] := VarPtr^[0];
+ ArgPtr^[1] := VarPtr^[1];
+ ArgPtr^[2] := VarPtr^[2];
+ ArgPtr^[3] := VarPtr^[3];
+ Inc(Integer(ParamPtr), 12);
+ end;
+ end else
+ begin
+ ArgPtr^[0] := ArgType;
+ ArgPtr^[2] := ParamPtr^;
+ if (ArgType >= varDouble) and (ArgType <= varDate) then
+ begin
+ Inc(Integer(ParamPtr), 4);
+ ArgPtr^[3] := ParamPtr^;
+ end;
+ end;
+ Inc(Integer(ParamPtr), 4);
+ end;
+ Inc(I);
+ until I = ArgCount;
+ end;
+ DispParams.rgvarg := @Args;
+ DispParams.rgdispidNamedArgs := @DispIDs[1];
+ DispParams.cArgs := ArgCount;
+ DispParams.cNamedArgs := CallDesc^.NamedArgCount;
+ DispID := DispIDs[0];
+ InvKind := CallDesc^.CallType;
+ if InvKind = DISPATCH_PROPERTYPUT then
+ begin
+ if Args[0][0] and varTypeMask = varDispatch then
+ InvKind := DISPATCH_PROPERTYPUTREF;
+ DispIDs[0] := DISPID_PROPERTYPUT;
+ Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
+ Inc(DispParams.cNamedArgs);
+ end else
+ if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
+ InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
+ Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
+ Result, @ExcepInfo, nil);
+ if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
+ J := StrCount;
+ while J <> 0 do
+ begin
+ Dec(J);
+ with Strings[J] do
+ if PStr <> nil then OleStrToStrVar(BStr, PStr^);
+ end;
+ finally
+ K := StrCount;
+ while K <> 0 do
+ begin
+ Dec(K);
+ SysFreeString(Strings[K].BStr);
+ end;
+ end;
+end;
+
+{ Call GetIDsOfNames method on the given IDispatch interface }
+
+procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PAnsiChar;
+ NameCount: Integer; DispIDs: PDispIDList);
+
+ procedure RaiseNameException;
+ begin
+ raise EOleError.CreateResFmt(e_Com, Integer( @SNoMethod ), [Names]);
+ end;
+
+type
+ PNamesArray = ^TNamesArray;
+ TNamesArray = array[0..0] of PWideChar;
+var
+ N, SrcLen, DestLen: Integer;
+ Src: PAnsiChar;
+ Dest: PWideChar;
+ NameRefs: PNamesArray;
+ StackTop: Pointer;
+ Temp: Integer;
+begin
+ Src := Names;
+ N := 0;
+ asm
+ MOV StackTop, ESP
+ MOV EAX, NameCount
+ INC EAX
+ SHL EAX, 2 // sizeof pointer = 4
+ SUB ESP, EAX
+ LEA EAX, NameRefs
+ MOV [EAX], ESP
+ end;
+ repeat
+ SrcLen := StrLen(Src);
+ DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1;
+ asm
+ MOV EAX, DestLen
+ ADD EAX, EAX
+ ADD EAX, 3 // round up to 4 byte boundary
+ AND EAX, not 3
+ SUB ESP, EAX
+ LEA EAX, Dest
+ MOV [EAX], ESP
+ end;
+ if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest;
+ MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen);
+ Dest[DestLen-1] := #0;
+ Inc(Src, SrcLen+1);
+ Inc(N);
+ until N = NameCount;
+ Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount,
+ GetThreadLocale, DispIDs);
+ if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp);
+ asm
+ MOV ESP, StackTop
+ end;
+end;
+
+{ Central call dispatcher }
+
+procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
+ CallDesc: PCallDesc; Params: Pointer); cdecl;
+
+ procedure RaiseException;
+ begin
+ raise EOleError.CreateResFmt(e_Com, Integer( @SVarNotObject ), [ nil ] );
+ end;
+
+var
+ Dispatch: Pointer;
+ DispIDs: array[0..MaxDispArgs - 1] of Integer;
+begin
+ if TVarData(Instance).VType = varDispatch then
+ Dispatch := TVarData(Instance).VDispatch
+ else if TVarData(Instance).VType = (varDispatch or varByRef) then
+ Dispatch := Pointer(TVarData(Instance).VPointer^)
+ else RaiseException;
+ GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
+ CallDesc^.NamedArgCount + 1, @DispIDs);
+ if Result <> nil then VarClear(Result^);
+ DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
+end;
+
+{ Raise exception given an OLE return code and TExcepInfo structure }
+
+procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo;
+ ErrorAddr: Pointer; FinalizeExcepInfo: Boolean);
+var
+ E: Exception;
+begin
+ if Status = Integer(DISP_E_EXCEPTION) then
+ begin
+ with ExcepInfo do
+ E := EOleException.Create(e_Com, bstrDescription {, scode, bstrSource,
+ bstrHelpFile, dwHelpContext } );
+ if FinalizeExcepInfo then
+ Finalize(ExcepInfo);
+ end else
+ E := EOleSysError.Create(e_com, '' {, Status, 0});
+ if ErrorAddr <> nil then
+ raise E at ErrorAddr
+ else
+ raise E;
+end;
+
+{ Raise exception given an OLE return code and TExcepInfo structure }
+
+procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
+begin
+ DispCallError(Status, PExcepInfo(@ExcepInfo)^, nil, False);
+end;
+
+procedure ClearExcepInfo(var ExcepInfo: TExcepInfo);
+begin
+ FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
+end;
+
+procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc;
+ DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall;
+type
+ TExcepInfoRec = record // mock type to avoid auto init and cleanup code
+ wCode: Word;
+ wReserved: Word;
+ bstrSource: PWideChar;
+ bstrDescription: PWideChar;
+ bstrHelpFile: PWideChar;
+ dwHelpContext: Longint;
+ pvReserved: Pointer;
+ pfnDeferredFillIn: Pointer;
+ scode: HResult;
+ end;
+var
+ DispParams: TDispParams;
+ ExcepInfo: TExcepInfoRec;
+asm
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+ MOV EBX,CallDesc
+ XOR EDX,EDX
+ MOV EDI,ESP
+ MOVZX ECX,[EBX].TCallDesc.ArgCount
+ MOV DispParams.cArgs,ECX
+ TEST ECX,ECX
+ JE @@10
+ ADD EBX,OFFSET TCallDesc.ArgTypes
+ MOV ESI,Params
+@@1: MOVZX EAX,[EBX].Byte
+ TEST AL,atByRef
+ JNE @@3
+ CMP AL,varVariant
+ JE @@2
+ CMP AL,varDouble
+ JB @@4
+ CMP AL,varDate
+ JA @@4
+ PUSH [ESI].Integer[4]
+ PUSH [ESI].Integer[0]
+ PUSH EDX
+ PUSH EAX
+ ADD ESI,8
+ JMP @@5
+@@2: PUSH [ESI].Integer[12]
+ PUSH [ESI].Integer[8]
+ PUSH [ESI].Integer[4]
+ PUSH [ESI].Integer[0]
+ ADD ESI,16
+ JMP @@5
+@@3: AND AL,atTypeMask
+ OR EAX,varByRef
+@@4: PUSH EDX
+ PUSH [ESI].Integer[0]
+ PUSH EDX
+ PUSH EAX
+ ADD ESI,4
+@@5: INC EBX
+ DEC ECX
+ JNE @@1
+ MOV EBX,CallDesc
+@@10: MOV DispParams.rgvarg,ESP
+ MOVZX EAX,[EBX].TCallDesc.NamedArgCount
+ MOV DispParams.cNamedArgs,EAX
+ TEST EAX,EAX
+ JE @@12
+ MOV ESI,NamedArgDispIDs
+@@11: PUSH [ESI].Integer[EAX*4-4]
+ DEC EAX
+ JNE @@11
+@@12: MOVZX ECX,[EBX].TCallDesc.CallType
+ CMP ECX,DISPATCH_PROPERTYPUT
+ JNE @@20
+ PUSH DISPID_PROPERTYPUT
+ INC DispParams.cNamedArgs
+ CMP [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch
+ JE @@13
+ CMP [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown
+ JNE @@20
+@@13: MOV ECX,DISPATCH_PROPERTYPUTREF
+@@20: MOV DispParams.rgdispidNamedArgs,ESP
+ PUSH EDX { ArgErr }
+ LEA EAX,ExcepInfo
+ PUSH EAX { ExcepInfo }
+ PUSH ECX
+ PUSH EDX
+ CALL ClearExcepInfo
+ POP EDX
+ POP ECX
+ PUSH Result { VarResult }
+ LEA EAX,DispParams
+ PUSH EAX { Params }
+ PUSH ECX { Flags }
+ PUSH EDX { LocaleID }
+ PUSH OFFSET GUID_NULL { IID }
+ PUSH DispID { DispID }
+ MOV EAX,Dispatch
+ PUSH EAX
+ MOV EAX,[EAX]
+ CALL [EAX].Pointer[24]
+ TEST EAX,EAX
+ JE @@30
+ LEA EDX,ExcepInfo
+ MOV CL, 1
+ PUSH ECX
+ MOV ECX,[EBP+4]
+ JMP DispCallError
+@@30: MOV ESP,EDI
+ POP EDI
+ POP ESI
+ POP EBX
+end;
+
+procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch;
+ DispDesc: PDispDesc; Params: Pointer); cdecl;
+asm
+ PUSH EBX
+ MOV EBX,DispDesc
+ XOR EAX,EAX
+ PUSH EAX
+ PUSH EAX
+ PUSH EAX
+ PUSH EAX
+ MOV EAX,ESP
+ PUSH EAX
+ LEA EAX,Params
+ PUSH EAX
+ PUSH EAX
+ PUSH [EBX].TDispDesc.DispID
+ LEA EAX,[EBX].TDispDesc.CallDesc
+ PUSH EAX
+ PUSH Dispatch
+ CALL DispCall
+ MOVZX EAX,[EBX].TDispDesc.ResType
+ MOV EBX,Result
+ JMP @ResultTable.Pointer[EAX*4]
+
+@ResultTable:
+ DD @ResEmpty
+ DD @ResNull
+ DD @ResSmallint
+ DD @ResInteger
+ DD @ResSingle
+ DD @ResDouble
+ DD @ResCurrency
+ DD @ResDate
+ DD @ResString
+ DD @ResDispatch
+ DD @ResError
+ DD @ResBoolean
+ DD @ResVariant
+ DD @ResUnknown
+ DD @ResDecimal
+ DD @ResError
+ DD @ResByte
+
+@ResSingle:
+ FLD [ESP+8].Single
+ JMP @ResDone
+
+@ResDouble:
+@ResDate:
+ FLD [ESP+8].Double
+ JMP @ResDone
+
+@ResCurrency:
+ FILD [ESP+8].Currency
+ JMP @ResDone
+
+@ResString:
+ MOV EAX,[EBX]
+ TEST EAX,EAX
+ JE @@1
+ PUSH EAX
+ CALL SysFreeString
+@@1: MOV EAX,[ESP+8]
+ MOV [EBX],EAX
+ JMP @ResDone
+
+@ResDispatch:
+@ResUnknown:
+ MOV EAX,[EBX]
+ TEST EAX,EAX
+ JE @@2
+ PUSH EAX
+ MOV EAX,[EAX]
+ CALL [EAX].Pointer[8]
+@@2: MOV EAX,[ESP+8]
+ MOV [EBX],EAX
+ JMP @ResDone
+
+@ResVariant:
+ MOV EAX,EBX
+ CALL System.@VarClear
+ MOV EAX,[ESP]
+ MOV [EBX],EAX
+ MOV EAX,[ESP+4]
+ MOV [EBX+4],EAX
+ MOV EAX,[ESP+8]
+ MOV [EBX+8],EAX
+ MOV EAX,[ESP+12]
+ MOV [EBX+12],EAX
+ JMP @ResDone
+
+@ResSmallint:
+@ResInteger:
+@ResBoolean:
+@ResByte:
+ MOV EAX,[ESP+8]
+
+@ResDecimal:
+@ResEmpty:
+@ResNull:
+@ResError:
+@ResDone:
+ ADD ESP,16
+ POP EBX
+end;
+
+var
+ ComClassManagerVar: TObject;
+ SaveInitProc: Pointer;
+ NeedToUninitialize: Boolean;
+
+function ComClassManager: TComClassManager;
+begin
+ if ComClassManagerVar = nil then
+ ComClassManagerVar := TComClassManager.Create;
+ Result := TComClassManager(ComClassManagerVar);
+end;
+
+procedure InitComObj;
+begin
+ if SaveInitProc <> nil then TProcedure(SaveInitProc);
+ if (CoInitFlags <> -1) and Assigned(KOLComObj.CoInitializeEx) then
+ begin
+ NeedToUninitialize := Succeeded(KOLComObj.CoInitializeEx(nil, CoInitFlags));
+ IsMultiThread := IsMultiThread or
+ ((CoInitFlags and COINIT_APARTMENTTHREADED) <> 0) or
+ (CoInitFlags = COINIT_MULTITHREADED); // this flag has value zero
+ end
+ else
+ NeedToUninitialize := Succeeded(CoInitialize(nil));
+end;
+
+
+initialization
+begin
+ LoadComExProcs;
+ VarDispProc := @VarDispInvoke;
+ DispCallByIDProc := @DispCallByID;
+ SafeCallErrorProc := @SafeCallError;
+ if not IsLibrary then
+ begin
+ SaveInitProc := InitProc;
+ InitProc := @InitComObj;
+ end;
+end;
+
+finalization
+begin
+ OleUninitializing := True;
+ ComClassManagerVar.Free;
+ SafeCallErrorProc := nil;
+ DispCallByIDProc := nil;
+ VarDispProc := nil;
+ if NeedToUninitialize then CoUninitialize;
+end;
+
+end.
|