8a71ebf5bc
git-svn-id: https://svn.code.sf.net/p/kolmck/code@67 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2353 lines
71 KiB
ObjectPascal
2353 lines
71 KiB
ObjectPascal
|
|
{*******************************************************}
|
|
{ }
|
|
{ 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: string; virtual; abstract;
|
|
function GetServerFileName: string; virtual; abstract;
|
|
function GetServerKey: string; virtual; abstract;
|
|
function GetServerName: string; virtual; abstract;
|
|
function GetStartSuspended: Boolean; virtual; abstract;
|
|
function GetTypeLib: ITypeLib; virtual; abstract;
|
|
procedure SetHelpFileName(const Value: string); virtual; abstract;
|
|
public
|
|
property HelpFileName: string read GetHelpFileName write SetHelpFileName;
|
|
property ServerFileName: string read GetServerFileName;
|
|
property ServerKey: string read GetServerKey;
|
|
property ServerName: string 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: string;
|
|
FDescription: string;
|
|
FErrorIID: TGUID;
|
|
FInstancing: TClassInstancing;
|
|
FLicString: WideString;
|
|
FRegister: Longint;
|
|
FShowErrors: Boolean;
|
|
FSupportsLicensing: Boolean;
|
|
FThreadingModel: TThreadingModel;
|
|
protected
|
|
function GetProgID: string; 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: string;
|
|
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: string read FClassName;
|
|
property ComClass: TClass read FComClass;
|
|
property ComServer: TComServerObject read FComServer;
|
|
property Description: string read FDescription;
|
|
property ErrorIID: TGUID read FErrorIID write FErrorIID;
|
|
property LicString: WideString read FLicString write FLicString;
|
|
property ProgID: string 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: string; ErrorCode: HRESULT;
|
|
HelpContext: Integer);
|
|
property ErrorCode: HRESULT read FErrorCode write FErrorCode;
|
|
end;}
|
|
|
|
EOleException = EOleSysError; { class(EOleSysError)
|
|
private
|
|
FSource: string;
|
|
FHelpFile: string;
|
|
public
|
|
constructor Create(const Message: string; ErrorCode: HRESULT;
|
|
const Source, HelpFile: string; HelpContext: Integer);
|
|
property HelpFile: string read FHelpFile write FHelpFile;
|
|
property Source: string 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: string): IDispatch;
|
|
function GetActiveOleObject(const ClassName: string): IDispatch;
|
|
|
|
procedure OleError(ErrorCode: HResult);
|
|
procedure OleCheck(Result: HResult);
|
|
|
|
function StringToGUID(const S: string): TGUID;
|
|
function GUIDToString(const ClassID: TGUID): string;
|
|
|
|
function ProgIDToClassID(const ProgID: string): TGUID;
|
|
function ClassIDToProgID(const ClassID: TGUID): string;
|
|
|
|
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: string;
|
|
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: string; 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: string;
|
|
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 string =
|
|
('', 'Apartment', 'Free', 'Both');
|
|
var
|
|
ClassID, ProgID, ServerKeyName, ShortFileName: string;
|
|
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: string;
|
|
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: string): string;
|
|
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: string;
|
|
ErrorCode: HRESULT; HelpContext: Integer);
|
|
var
|
|
S: string;
|
|
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: string; ErrorCode: HRESULT;
|
|
const Source, HelpFile: string; 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 string to a GUID }
|
|
|
|
function StringToGUID(const S: string): TGUID;
|
|
begin
|
|
OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
|
|
end;
|
|
|
|
{ Convert a GUID to a string }
|
|
|
|
function GUIDToString(const ClassID: TGUID): string;
|
|
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: string): TGUID;
|
|
begin
|
|
OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
|
|
end;
|
|
|
|
{ Convert a class ID to a programmatic ID }
|
|
|
|
function ClassIDToProgID(const ClassID: TGUID): string;
|
|
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: string): 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: string): 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: PString;
|
|
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(PString(ParamPtr^)^);
|
|
PStr := PString(ParamPtr^);
|
|
ArgPtr^[0] := varOleStr or varByRef;
|
|
ArgPtr^[2] := Integer(@BStr);
|
|
end else
|
|
begin
|
|
BStr := StringToOleStr(PString(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(string(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: PChar;
|
|
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: PChar;
|
|
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.
|