{ This file is part of the Free Pascal run time library. Copyright (c) 2006 by Florian Klaempfl member of the Free Pascal development team. See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {$mode objfpc} {$H+} {$inline on} unit comobj; interface { $define DEBUG_COM} { $define DEBUG_COMDISPATCH} {$ifdef wince} {$define DUMMY_REG} {$endif} uses Windows,Types,Variants,Sysutils,ActiveX,classes; type EOleError = class(Exception); // apparantly used by axctrls. // http://lazarus.freepascal.org/index.php/topic,11612.0.html TConnectEvent = procedure(const Sink: IUnknown; Connecting: Boolean) of object; EOleSysError = class(EOleError) private FErrorCode: HRESULT; public constructor Create(const Msg: string; aErrorCode: HRESULT;aHelpContext: Integer); property ErrorCode: HRESULT read FErrorCode write FErrorCode; end; EOleException = class(EOleSysError) private FHelpFile: string; FSource: string; public constructor Create(const Msg: string; aErrorCode: HRESULT;const aSource,aHelpFile: string;aHelpContext: Integer); property HelpFile: string read FHelpFile write FHelpFile; property Source: string read FSource write FSource; end; EOleRegistrationError = class(EOleSysError); TOleStream = Class(TProxyStream) procedure Check(err:integer);override; end; 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; TComObjectFactory = class; TFactoryProc = procedure(Factory: TComObjectFactory) of object; { TComClassManager } TComClassManager = class(TObject) private fClassFactoryList: TList; public constructor Create; destructor Destroy; override; procedure AddObjectFactory(factory: TComObjectFactory); procedure RemoveObjectFactory(factory: TComObjectFactory); procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc); function GetFactoryFromClass(ComClass: TClass): TComObjectFactory; function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory; end; IServerExceptionHandler = interface ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}'] procedure OnException(const ServerClass, ExceptionClass, ErrorMessage: WideString; ExceptAddr: PtrInt; const ErrorIID, ProgID: WideString; var Handled: Integer; var Result: HResult); dispid 2; end; TComObject = class(TObject, IUnknown, ISupportErrorInfo) private FController : Pointer; FFactory : TComObjectFactory; FRefCount : Integer; FServerExceptionHandler : IServerExceptionHandler; FCounted : Boolean; function GetController : IUnknown; protected { IUnknown } function IUnknown.QueryInterface = ObjQueryInterface; function IUnknown._AddRef = ObjAddRef; function IUnknown._Release = ObjRelease; { IUnknown methods for other interfaces } function QueryInterface(constref 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(constref 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; TComClass = class of TComObject; TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance); TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth, tmNeutral); { TComObjectFactory } TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2) private FRefCount : Integer; //Next: TComObjectFactory; FComServer: TComServerObject; FComClass: TClass; FClassID: TGUID; FClassName: string; FClassVersion : String; FDescription: string; FErrorIID: TGUID; FInstancing: TClassInstancing; FLicString: WideString; //FRegister: Longint; FShowErrors: Boolean; FSupportsLicensing: Boolean; FThreadingModel: TThreadingModel; function GetProgID: string; protected { IUnknown } function QueryInterface(constref 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: DWORD; 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 Name, Description: string; Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle); constructor Create(ComServer: TComServerObject; ComClass: TComClass; const ClassID: TGUID; const Name, Version, 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 ClassVersion: string read FClassVersion; 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; { TTypedComObject } TTypedComObject = class(TComObject, IProvideClassInfo) function GetClassInfo(out pptti : ITypeInfo):HResult; StdCall; end; TTypedComClass = class of TTypedComObject; { TTypedComObjectFactory } TTypedComObjectFactory = class(TComObjectFactory) private FClassInfo: ITypeInfo; FTypeInfoCount:integer; public constructor Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID; AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle); function GetInterfaceTypeInfo(TypeFlags: Integer) : ITypeInfo; procedure UpdateRegistry(Register: Boolean);override; property ClassInfo : ITypeInfo read FClassInfo; end; { TAutoObject } TAutoObject = class(TTypedComObject, IDispatch) protected { IDispatch } function GetTypeInfoCount(out count : longint) : HResult;stdcall; function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall; function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall; function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall; public end; TAutoClass = class of TAutoObject; { TAutoObjectFactory } TAutoObjectFactory = class(TTypedComObjectFactory) private FDispIntfEntry: PInterfaceEntry; FDispTypeInfo: ITypeInfo; public constructor Create(AComServer: TComServerObject; AutoClass: TAutoClass; const AClassID: TGUID; AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle); function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual; property DispIntfEntry: PInterfaceEntry read FDispIntfEntry; property DispTypeInfo: ITypeInfo read FDispTypeInfo; end; { TAutoIntfObject } //example of how to implement IDispatch: http://www.opensource.apple.com/source/vim/vim-34/vim/src/if_ole.cpp TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo) private fTypeInfo: ITypeInfo; fInterfacePointer: Pointer; protected { IDispatch } function GetTypeInfoCount(out count : longint) : HResult;stdcall; function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall; function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall; function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall; { ISupportErrorInfo } function InterfaceSupportsErrorInfo(CONST riid: TIID):HResult;StdCall; public function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override; constructor Create(TypeLib: ITypeLib; const Guid: TGuid); end; function CreateClassID : ansistring; 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 OleCheck(Value : HResult);inline; procedure OleError(Code: HResult); function ProgIDToClassID(const id : string) : TGUID; function ClassIDToProgID(const classID: TGUID): string; procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc; DispIDs: PDispIDList; Params: Pointer; Result: PVariant); procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo); function HandleSafeCallException(ExceptObject: TObject; ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID, HelpFileName: WideString): HResult; function ComClassManager : TComClassManager; procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: HKey= HKEY_CLASSES_ROOT); procedure DeleteRegKey(const Key: string; RootKey: HKey = HKEY_CLASSES_ROOT); function GetRegStringValue(const Key, ValueName: string; RootKey: HKey = HKEY_CLASSES_ROOT): string; type TCoCreateInstanceExProc = function(const clsid: TCLSID; unkOuter: IUnknown; dwClsCtx: DWORD; ServerInfo: PCoServerInfo; dwCount: ULONG; rgmqResults: PMultiQIArray): HResult stdcall; TCoInitializeExProc = function (pvReserved: Pointer; coInit: DWORD): HResult; stdcall; TCoAddRefServerProcessProc = function : ULONG; stdcall; TCoReleaseServerProcessProc = function : ULONG; stdcall; TCoResumeClassObjectsProc = function : HResult; stdcall; TCoSuspendClassObjectsProc = function : HResult; stdcall; const CoCreateInstanceEx : TCoCreateInstanceExProc = nil; CoInitializeEx : TCoInitializeExProc = nil; CoAddRefServerProcess : TCoAddRefServerProcessProc = nil; CoReleaseServerProcess : TCoReleaseServerProcessProc = nil; CoResumeClassObjects : TCoResumeClassObjectsProc = nil; CoSuspendClassObjects : TCoSuspendClassObjectsProc = nil; CoInitFlags : Longint = -1; {$ifdef DEBUG_COM} var printcom : boolean=true; {$endif} implementation uses ComConst, Ole2, {$ifndef dummy_reg} Registry, {$endif} RtlConsts; var Uninitializing : boolean; function HandleSafeCallException(ExceptObject: TObject; ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID, HelpFileName: WideString): HResult; {$ifndef wince} var _CreateErrorInfo : ICreateErrorInfo; ErrorInfo : IErrorInfo; {$endif wince} begin Result:=E_UNEXPECTED; {$ifndef wince} if Succeeded(CreateErrorInfo(_CreateErrorInfo)) then begin _CreateErrorInfo.SetGUID(ErrorIID); if ProgID<>'' then _CreateErrorInfo.SetSource(PWidechar(ProgID)); if HelpFileName<>'' then _CreateErrorInfo.SetHelpFile(PWidechar(HelpFileName)); if ExceptObject is Exception then begin _CreateErrorInfo.SetDescription(PWidechar(Widestring(Exception(ExceptObject).Message))); _CreateErrorInfo.SetHelpContext(Exception(ExceptObject).HelpContext); if (ExceptObject is EOleSyserror) and (EOleSysError(ExceptObject).ErrorCode<0) then Result:=EOleSysError(ExceptObject).ErrorCode end; if _CreateErrorInfo.QueryInterface(IErrorInfo,ErrorInfo)=S_OK then SetErrorInfo(0,ErrorInfo); end; {$endif wince} end; constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer); var m : string; begin if Msg='' then m:=SysErrorMessage(aErrorCode) else m:=Msg; inherited CreateHelp(m,HelpContext); FErrorCode:=aErrorCode; end; constructor EOleException.Create(const Msg: string; aErrorCode: HRESULT;const aSource,aHelpFile: string; aHelpContext: Integer); begin inherited Create(Msg,aErrorCode,aHelpContext); FHelpFile:=aHelpFile; FSource:=aSource; end; {$define FPC_COMOBJ_HAS_CREATE_CLASS_ID} function CreateClassID : ansistring; var ClassID : TCLSID; p : PWideChar; begin CoCreateGuid(ClassID); StringFromCLSID(ClassID,p); result:=p; CoTaskMemFree(p); 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; var flags : DWORD; localhost : array[0..MAX_COMPUTERNAME_LENGTH] of WideChar; server : TCoServerInfo; mqi : TMultiQI; size : DWORD; begin if not(assigned(CoCreateInstanceEx)) then raise Exception.CreateRes(@SDCOMNotInstalled); FillChar(server,sizeof(server),0); server.pwszName:=PWideChar(MachineName); FillChar(mqi,sizeof(mqi),0); mqi.iid:=@IID_IUnknown; flags:=CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER; { actually a remote call? } {$ifndef wince} //roozbeh although there is a way to retrive computer name...HKLM\Ident\Name..but are they same? size:=sizeof(localhost); if (MachineName<>'') and (not(GetComputerNameW(localhost,size)) or (WideCompareText(localhost,MachineName)<>0)) then flags:=CLSCTX_REMOTE_SERVER; {$endif} OleCheck(CoCreateInstanceEx(ClassID,nil,flags,@server,1,@mqi)); OleCheck(mqi.hr); Result:=mqi.itf; end; function CreateOleObject(const ClassName : string) : IDispatch; var id : TCLSID; begin id:=ProgIDToClassID(ClassName); OleCheck(CoCreateInstance(id,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IDispatch,result)); end; function GetActiveOleObject(const ClassName : string) : IDispatch; {$ifndef wince} var intf : IUnknown; id : TCLSID; begin id:=ProgIDToClassID(ClassName); OleCheck(GetActiveObject(id,nil,intf)); OleCheck(intf.QueryInterface(IDispatch,Result)); end; {$else} begin Result:=nil; end; {$endif wince} procedure CreateRegKey(const Key, ValueName, Value: string; RootKey: HKEY = HKEY_CLASSES_ROOT); {$ifndef DUMMY_REG} var Reg: TRegistry; {$endif} begin {$ifdef DEBUG_COM} if printcom then WriteLn('CreateRegKey: ', Key, ': ', ValueName, ': ', Value ); {$endif} {$ifndef DUMMY_REG} Reg := TRegistry.Create; try Reg.RootKey := RootKey; if Reg.OpenKey(Key, True) then begin try Reg.WriteString(ValueName, Value); finally Reg.CloseKey; end; end else raise EOleRegistrationError.CreateResFmt(@SRegCreateFailed,[Key]); finally Reg.Free; end; {$endif} {$ifdef DEBUG_COM} if printcom then WriteLn('CreateRegKey exit: ', Key, ': ', ValueName, ': ', Value ); {$endif} end; procedure DeleteRegKey(const Key: string; RootKey: HKEY = HKEY_CLASSES_ROOT); {$ifndef DUMMY_REG} var Reg: TRegistry; {$endif} begin {$ifdef DEBUG_COM} if printcom then WriteLn('DeleteRegKey: ', Key); {$endif} {$ifndef DUMMY_REG} Reg := TRegistry.Create; try Reg.RootKey := RootKey; Reg.DeleteKey(Key); finally Reg.Free; end; {$endif} end; function GetRegStringValue(const Key, ValueName: string; RootKey: HKEY = HKEY_CLASSES_ROOT): string; {$ifndef DUMMY_REG} var Reg: TRegistry; {$endif} begin {$ifndef DUMMY_REG} Reg := TRegistry.Create(); try Reg.RootKey := RootKey; if Reg.OpenKeyReadOnly(Key) then begin try Result := Reg.ReadString(ValueName) finally Reg.CloseKey; end; end else Result := ''; finally Reg.Free; end; {$endif} end; procedure OleError(Code: HResult); begin raise EOleSysError.Create('',Code,0); end; procedure OleCheck(Value : HResult);inline; begin if not(Succeeded(Value)) then OleError(Value); end; function ProgIDToClassID(const id : string) : TGUID; begin OleCheck(CLSIDFromProgID(PWideChar(WideString(id)),result)); end; function ClassIDToProgID(const classID: TGUID): string; var progid : LPOLESTR; begin OleCheck(ProgIDFromCLSID(@classID,progid)); result:=progid; CoTaskMemFree(progid); end; procedure SafeCallErrorHandler(err : HResult;addr : pointer); {$ifndef wince} var info : IErrorInfo; descr,src,helpfile : widestring; helpctx : DWORD; {$endif wince} begin {$ifndef wince} if GetErrorInfo(0,info)=S_OK then begin info.GetDescription(descr); info.GetSource(src); info.GetHelpFile(helpfile); info.GetHelpContext(helpctx); raise EOleException.Create(descr,err,src,helpfile,helpctx) at addr; end else {$endif wince} raise EOleException.Create('',err,'','',0) at addr; end; procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo); begin if Status=DISP_E_EXCEPTION then raise EOleException.Create(ExceptInfo.Description,ExceptInfo.scode,ExceptInfo.Source, ExceptInfo.HelpFile,ExceptInfo.dwHelpContext) else raise EOleSysError.Create('',Status,0); end; var _ComClassManager : TComClassManager; function ComClassManager: TComClassManager; begin if not(assigned(_ComClassManager)) then _ComClassManager:=TComClassManager.Create; Result:=_ComClassManager; end; constructor TComClassManager.Create; begin fClassFactoryList := TList.create({true}); end; destructor TComClassManager.Destroy; var i : integer; begin if fClassFactoryList.count>0 Then begin for i:=fClassFactoryList.count-1 downto 0 do tobject(fClassFactoryList[i]).Free; end; fClassFactoryList.Free; end; procedure TComClassManager.AddObjectFactory(factory: TComObjectFactory); begin {$ifdef DEBUG_COM} if printcom then WriteLn('AddObjectFactory: ', GUIDToString(factory.FClassID), ' ', factory.FClassName); {$endif} fClassFactoryList.Add(factory); end; procedure TComClassManager.RemoveObjectFactory( factory: TComObjectFactory); begin fClassFactoryList.Remove(factory); end; procedure TComClassManager.ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc); var i: Integer; obj: TComObjectFactory; begin {$ifdef DEBUG_COM} if printcom then WriteLn('ForEachFactory'); {$endif} for i := 0 to fClassFactoryList.Count - 1 do begin obj := TComObjectFactory(fClassFactoryList[i]); if obj.ComServer = ComServer then FactoryProc(obj); end; end; function TComClassManager.GetFactoryFromClass(ComClass: TClass ): TComObjectFactory; var i: Integer; begin {$ifdef DEBUG_COM} if printcom then WriteLn('GetFactoryFromClass: ', ComClass.ClassName); {$endif} for i := 0 to fClassFactoryList.Count - 1 do begin Result := TComObjectFactory(fClassFactoryList[i]); if ComClass = Result.ComClass then Exit(); end; Result := nil; end; function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID ): TComObjectFactory; var i: Integer; begin {$ifdef DEBUG_COM} if printcom then WriteLn('GetFactoryFromClassID: ', GUIDToString(ClassId)); {$endif} for i := 0 to fClassFactoryList.Count - 1 do begin Result := TComObjectFactory(fClassFactoryList[i]); if IsEqualGUID(ClassID, Result.ClassID) then Exit(); end; {$ifdef DEBUG_COM} if printcom then WriteLn('GetFactoryFromClassID not found: ', GUIDToString(ClassId)); {$endif} Result := nil; end; function TComObject.GetController: IUnknown; begin Result:=IUnknown(Controller); end; function TComObject.QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall; begin if assigned(FController) then Result:=IUnknown(FController).QueryInterface(IID,Obj) else Result:=ObjQueryInterface(IID,Obj); end; function TComObject._AddRef: Integer; stdcall; begin if assigned(FController) then Result:=IUnknown(FController)._AddRef else Result:=ObjAddRef; end; function TComObject._Release: Integer; stdcall; begin if assigned(FController) then Result:=IUnknown(FController)._Release else Result:=ObjRelease; end; function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall; begin if assigned(GetInterfaceEntry(iid)) then Result:=S_OK else Result:=S_FALSE; end; constructor TComObject.Create; begin CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType),nil); end; constructor TComObject.CreateAggregated(const Controller: IUnknown); begin CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType),Controller); end; constructor TComObject.CreateFromFactory(Factory: TComObjectFactory; const Controller: IUnknown); begin FFactory:=Factory; FRefCount:=1; FController:=Pointer(Controller); FFactory.Comserver.CountObject(True); FCounted:=true; Initialize; Dec(FRefCount); end; destructor TComObject.Destroy; begin if not(Uninitializing) then begin if assigned(FFactory) and FCounted then FFactory.Comserver.CountObject(false); {$ifndef wince} if FRefCount>0 then CoDisconnectObject(Self,0); {$endif wince} end; end; procedure TComObject.Initialize; begin end; function TComObject.ObjAddRef: Integer; stdcall; begin Result:=InterlockedIncrement(FRefCount); end; function TComObject.ObjQueryInterface(constref IID: TGUID; out Obj): HResult; stdcall; begin if GetInterface(IID,Obj) then Result:=S_OK else Result:=E_NOINTERFACE; end; function TComObject.ObjRelease: Integer; stdcall; begin Result:=InterlockedDecrement(FRefCount); if Result=0 then Self.Destroy; end; function TComObject.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; var Message: string; Handled: Integer; begin Handled:=0; Result:=0; if assigned(ServerExceptionHandler) then begin if ExceptObject is Exception then Message:=Exception(ExceptObject).Message; ServerExceptionHandler.OnException(ClassName,ExceptObject.ClassName, Message,PtrInt(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; function TComObjectFactory.GetProgID: string; begin Result := FComServer.GetServerName + '.' + FClassName; end; function TComObjectFactory.QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall; begin if GetInterface(IID,Obj) then Result:=S_OK else Result:=E_NOINTERFACE; end; function TComObjectFactory._AddRef: Integer; stdcall; begin Result:=InterlockedIncrement(FRefCount); end; function TComObjectFactory._Release: Integer; stdcall; begin Result:=InterlockedDecrement(FRefCount); if Result=0 then Self.Destroy; end; function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; stdcall; var comObject: TComObject; begin {$ifdef DEBUG_COM} if printcom then WriteLn('CreateInstance: ', GUIDToString(IID)); {$endif} comObject := CreateComObject(UnkOuter); if comObject.GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TComObjectFactory.LockServer(fLock: BOOL): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('LockServer: ', fLock); {$endif} RunError(217); Result:=0; end; function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('GetLicInfo'); {$endif} RunError(217); Result:=0; end; function TComObjectFactory.RequestLicKey(dwResrved: DWORD; out bstrKey: WideString): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('RequestLicKey'); {$endif} RunError(217); Result:=0; end; function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('CreateInstanceLic'); {$endif} RunError(217); Result:=0; end; constructor TComObjectFactory.Create(ComServer: TComServerObject; ComClass: TComClass; const ClassID: TGUID; const Name, Description: string; Instancing: TClassInstancing; ThreadingModel: TThreadingModel); begin Create(ComServer, ComClass, ClassID, Name, '', Description, Instancing, ThreadingModel); end; constructor TComObjectFactory.Create(ComServer: TComServerObject; ComClass: TComClass; const ClassID: TGUID; const Name, Version, Description: string; Instancing: TClassInstancing; ThreadingModel: TThreadingModel); begin {$ifdef DEBUG_COM} if printcom then WriteLn('TComObjectFactory.Create'); {$endif} FRefCount := 1; FClassID := ClassID; FThreadingModel := ThreadingModel; FDescription := Description; FClassName := Name; FClassVersion := Version; FComServer := ComServer; FComClass := ComClass; FInstancing := Instancing;; ComClassManager.AddObjectFactory(Self); end; destructor TComObjectFactory.Destroy; begin ComClassManager.RemoveObjectFactory(Self); //RunError(217); end; function TComObjectFactory.CreateComObject(const Controller: IUnknown ): TComObject; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TComObjectFactory.CreateComObject'); {$endif} Result := TComClass(FComClass).Create(); end; procedure TComObjectFactory.RegisterClassObject; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TComObjectFactory.RegisterClassObject'); {$endif} RunError(217); end; (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx) HKCR { %PROGID%.%VERSION% = s '%DESCRIPTION%' { CLSID = s '%CLSID%' } %PROGID% = s '%DESCRIPTION%' { CLSID = s '%CLSID%' CurVer = s '%PROGID%.%VERSION%' } NoRemove CLSID { ForceRemove %CLSID% = s '%DESCRIPTION%' { ProgID = s '%PROGID%.%VERSION%' VersionIndependentProgID = s '%PROGID%' ForceRemove 'Programmable' InprocServer32 = s '%MODULE%' { val ThreadingModel = s '%THREADING%' } 'TypeLib' = s '%LIBID%' } } } *) procedure TComObjectFactory.UpdateRegistry(Register: Boolean); var classidguid: String; function ThreadModelToString(model: TThreadingModel): String; begin case model of tmSingle: Result := ''; tmApartment: Result := 'Apartment'; tmFree: Result := 'Free'; tmBoth: Result := 'Both'; tmNeutral: Result := 'Neutral'; end; end; begin {$ifndef DUMMY_REG} {$ifdef DEBUG_COM} if printcom then WriteLn('UpdateRegistry begin'); {$endif} if Instancing = ciInternal then Exit; if Register then begin classidguid := GUIDToString(ClassID); CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName); //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel)); CreateRegKey('CLSID\' + classidguid, '', Description); if ClassName <> '' then begin if ClassVersion <> '' then begin CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID + '.' + ClassVersion); CreateRegKey('CLSID\' + classidguid + '\VersionIndependentProgID', '', ProgID); end else CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID); CreateRegKey(ProgID, '', Description); CreateRegKey(ProgID + '\CLSID', '', GUIDToString(ClassID)); if ClassVersion <> '' then begin CreateRegKey(ProgID + '\CurVer', '', ProgID + '.' + ClassVersion); CreateRegKey(ProgID + '.' + ClassVersion, '', Description); CreateRegKey(ProgID + '.' + ClassVersion + '\CLSID', '', GUIDToString(ClassID)); end; end; end else begin classidguid := GUIDToString(ClassID); DeleteRegKey('CLSID\' + classidguid + '\InprocServer32'); DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID'); if ClassName <> '' then begin DeleteRegKey('CLSID\' + classidguid + '\ProgID'); DeleteRegKey(ProgID + '\CLSID'); if ClassVersion <> '' then begin DeleteRegKey(ProgID + '\CurVer'); DeleteRegKey(ProgID + '.' + ClassVersion + '\CLSID'); DeleteRegKey(ProgID + '.' + ClassVersion); end; DeleteRegKey(ProgID); end; DeleteRegKey('CLSID\' + classidguid); end; {$ifdef DEBUG_COM} if printcom then WriteLn('UpdateRegistry end'); {$endif} {$endif DUMMY_REG} end; procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc; DispIDs: PDispIDList; Params: Pointer; Result: PVariant); var { we can't pass pascal ansistrings to COM routines so we've to convert them to/from widestring. This array contains the mapping to do so } StringMap : array[0..255] of record passtr : pansistring; comstr : pwidechar; end; invokekind, i : longint; invokeresult : HResult; exceptioninfo : TExcepInfo; dispparams : TDispParams; NextString : SizeInt; Arguments : array[0..255] of TVarData; CurrType : byte; MethodID : TDispID; begin NextString:=0; fillchar(dispparams,sizeof(dispparams),0); try {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('DispatchInvoke: Got ',CallDesc^.ArgCount,' arguments NamedArgs = ',CallDesc^.NamedArgCount); {$endif DEBUG_COMDISPATCH} { copy and prepare arguments } for i:=0 to CallDesc^.ArgCount-1 do begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('DispatchInvoke: Params = ',hexstr(Params)); {$endif DEBUG_COMDISPATCH} { get plain type } CurrType:=CallDesc^.ArgTypes[i] and $3f; { a skipped parameter? Don't increment Params pointer if so. } if CurrType=varError then begin Arguments[i].vType:=varError; Arguments[i].vError:=DISP_E_PARAMNOTFOUND; continue; end; { by reference? } if (CallDesc^.ArgTypes[i] and $80)<>0 then begin case CurrType of varStrArg: begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('Translating var ansistring argument ',PString(Params^)^); {$endif DEBUG_COMDISPATCH} StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^); StringMap[NextString].PasStr:=PString(Params^); Arguments[i].VType:=varOleStr or varByRef; Arguments[i].VPointer:=StringMap[NextString].ComStr; inc(NextString); inc(PPointer(Params)); end; varVariant: begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('Got ref. variant containing type: ',PVarData(PPointer(Params)^)^.VType); {$endif DEBUG_COMDISPATCH} if PVarData(PPointer(Params)^)^.VType=varString then begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln(' Casting nested varString: ',Ansistring(PVarData(Params^)^.vString)); {$endif DEBUG_COMDISPATCH} VarCast(PVariant(Params^)^,PVariant(Params^)^,varOleStr); end; Arguments[i].VType:=varVariant or varByRef; Arguments[i].VPointer:=PPointer(Params)^; inc(PPointer(Params)); end else begin {$ifdef DEBUG_COMDISPATCH} if printcom then write('DispatchInvoke: Got ref argument with type = ',CurrType); case CurrType of varOleStr: if printcom then write(' Value = ',pwidestring(PPointer(Params)^)^); end; if printcom then writeln; {$endif DEBUG_COMDISPATCH} Arguments[i].VType:=CurrType or VarByRef; Arguments[i].VPointer:=PPointer(Params)^; inc(PPointer(Params)); end; end end else { by-value argument } case CurrType of varStrArg: begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('Translating ansistring argument ',PString(Params)^); {$endif DEBUG_COMDISPATCH} StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^); StringMap[NextString].PasStr:=nil; Arguments[i].VType:=varOleStr; Arguments[i].VPointer:=StringMap[NextString].ComStr; inc(NextString); inc(PPointer(Params)); end; varVariant: begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('By-value Variant, making a copy'); {$endif DEBUG_COMDISPATCH} { Codegen always passes a pointer to variant, *unlike* Delphi which pushes the entire TVarData } Arguments[i]:=PVarData(PPointer(Params)^)^; Inc(PPointer(Params)); end; varCurrency, varDouble, varInt64, varQWord, varDate: begin {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('Got 8 byte argument'); {$endif DEBUG_COMDISPATCH} Arguments[i].VType:=CurrType; Arguments[i].VDouble:=PDouble(Params)^; inc(PDouble(Params)); end; else begin {$ifdef DEBUG_COMDISPATCH} if printcom then write('DispatchInvoke: Got argument with type ',CurrType); case CurrType of varOleStr: if printcom then write(' Value = ',pwidestring(Params)^); else if printcom then write(' Value = ',hexstr(PtrInt(PPointer(Params)^),SizeOf(Pointer)*2)); end; writeln; {$endif DEBUG_COMDISPATCH} Arguments[i].VType:=CurrType; Arguments[i].VPointer:=PPointer(Params)^; inc(PPointer(Params)); end; end; end; { finally prepare the call } with DispParams do begin rgvarg:=@Arguments; cNamedArgs:=CallDesc^.NamedArgCount; if cNamedArgs=0 then rgdispidNamedArgs:=nil else rgdispidNamedArgs:=@DispIDs^[1]; cArgs:=CallDesc^.ArgCount; end; InvokeKind:=CallDesc^.CallType; MethodID:=DispIDs^[0]; case InvokeKind of DISPATCH_PROPERTYPUT: begin if (Arguments[0].VType and varTypeMask) = varDispatch then InvokeKind:=DISPATCH_PROPERTYPUTREF; { first name is actually the name of the property to set } DispIDs^[0]:=DISPID_PROPERTYPUT; DispParams.rgdispidNamedArgs:=@DispIDs^[0]; inc(DispParams.cNamedArgs); end; DISPATCH_METHOD: if assigned(Result) and (CallDesc^.ArgCount=0) then InvokeKind:=DISPATCH_METHOD or DISPATCH_PROPERTYGET; end; {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('DispatchInvoke: MethodID: ',MethodID,' InvokeKind: ',InvokeKind); {$endif DEBUG_COMDISPATCH} { do the call and check the result } invokeresult:=Dispatch.Invoke(MethodID,GUID_NULL,0,InvokeKind,DispParams,result,@exceptioninfo,nil); if invokeresult<>0 then DispatchInvokeError(invokeresult,exceptioninfo); { translate strings back } for i:=0 to NextString-1 do if assigned(StringMap[i].passtr) then OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^); finally for i:=0 to NextString-1 do SysFreeString(StringMap[i].ComStr); end; end; procedure SearchIDs(const DispatchInterface : IDispatch; Names: PChar; Count: Integer; IDs: PDispIDList); var res : HRESULT; NamesArray : ^PWideChar; NamesData : PWideChar; OrigNames : PChar; NameCount, NameLen, NewNameLen, CurrentNameDataUsed, CurrentNameDataSize : SizeInt; i : longint; begin getmem(NamesArray,Count*sizeof(PWideChar)); CurrentNameDataSize:=256; CurrentNameDataUsed:=0; getmem(NamesData,CurrentNameDataSize); NameCount:=0; OrigNames:=Names; {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('SearchIDs: Searching ',Count,' IDs'); {$endif DEBUG_COMDISPATCH} for i:=1 to Count do begin NameLen:=strlen(Names); {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen); {$endif DEBUG_COMDISPATCH} NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1; if (CurrentNameDataUsed+NewNameLen)*2>CurrentNameDataSize then begin inc(CurrentNameDataSize,256); reallocmem(NamesData,CurrentNameDataSize); end; NamesArray[i-1]:=@NamesData[CurrentNameDataUsed]; MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen); NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0; {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('SearchIDs: Translated name: ',WideString(PWideChar(@NamesData[CurrentNameDataUsed]))); {$endif DEBUG_COMDISPATCH} inc(CurrentNameDataUsed,NewNameLen); inc(Names,NameLen+1); inc(NameCount); end; res:=DispatchInterface.GetIDsOfNames(GUID_NULL,NamesArray,NameCount, {$ifdef wince} LOCALE_SYSTEM_DEFAULT {$else wince} GetThreadLocale {$endif wince} ,IDs); {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('SearchIDs: GetIDsOfNames result = ',hexstr(res,SizeOf(HRESULT)*2)); for i:=0 to Count-1 do writeln('SearchIDs: ID[',i,'] = ',ids^[i]); {$endif DEBUG_COMDISPATCH} if res=DISP_E_UNKNOWNNAME then raise EOleError.createresfmt(@snomethod,[OrigNames]) else OleCheck(res); freemem(NamesArray); freemem(NamesData); end; procedure ComObjDispatchInvoke(dest : PVariant;const source : Variant; calldesc : pcalldesc;params : pointer);cdecl; var dispatchinterface : pointer; ids : array[0..255] of TDispID; begin fillchar(ids,sizeof(ids),0); {$ifdef DEBUG_COMDISPATCH} if printcom then writeln('ComObjDispatchInvoke called'); if printcom then writeln('ComObjDispatchInvoke: @CallDesc = $',hexstr(PtrInt(CallDesc),SizeOf(Pointer)*2),' CallDesc^.ArgCount = ',CallDesc^.ArgCount); {$endif DEBUG_COMDISPATCH} if tvardata(source).vtype=VarDispatch then dispatchinterface:=tvardata(source).vdispatch else if tvardata(source).vtype=(VarDispatch or VarByRef) then dispatchinterface:=pvardata(tvardata(source).vpointer)^.vdispatch else raise eoleerror.createres(@SVarNotObject); SearchIDs(IDispatch(dispatchinterface),@CallDesc^.ArgTypes[CallDesc^.ArgCount], CallDesc^.NamedArgCount+1,@ids); if assigned(dest) then VarClear(dest^); DispatchInvoke(IDispatch(dispatchinterface),calldesc,@ids,params,dest); end; { $define DEBUG_DISPATCH} procedure DoDispCallByID(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer); var exceptioninfo : TExcepInfo; dispparams : TDispParams; flags : WORD; invokeresult : HRESULT; preallocateddata : array[0..15] of TVarData; Arguments : PVarData; CurrType, i : byte; dispidNamed: TDispID; begin { use preallocated space, i.e. can we avoid a getmem call? } if desc^.calldesc.argcount<=Length(preallocateddata) then Arguments:=@preallocateddata else GetMem(Arguments,desc^.calldesc.argcount*sizeof(TVarData)); { prepare parameters } if desc^.CallDesc.ArgCount > 0 then for i:=0 to desc^.CallDesc.ArgCount-1 do begin {$ifdef DEBUG_DISPATCH} writeln('DoDispCallByID: Params = ',hexstr(Params)); {$endif DEBUG_DISPATCH} { get plain type } CurrType:=desc^.CallDesc.ArgTypes[i] and $3f; { by reference? } if (desc^.CallDesc.ArgTypes[i] and $80)<>0 then begin {$ifdef DEBUG_DISPATCH} write('DispatchInvoke: Got ref argument with type = ',CurrType); writeln; {$endif DEBUG_DISPATCH} Arguments[i].VType:=CurrType or VarByRef; Arguments[i].VPointer:=PPointer(Params)^; inc(PPointer(Params)); end else begin {$ifdef DEBUG_DISPATCH} writeln('DispatchInvoke: Got value argument with type = ',CurrType); {$endif DEBUG_DISPATCH} case CurrType of varVariant: begin { Codegen always passes a pointer to variant, *unlike* Delphi which pushes the entire TVarData } Arguments[i]:=PVarData(PPointer(Params)^)^; inc(PPointer(Params)); end; varCurrency, varDouble, varInt64, varQWord, varDate: begin {$ifdef DEBUG_DISPATCH} writeln('DispatchInvoke: Got 8 byte argument'); {$endif DEBUG_DISPATCH} Arguments[i].VType:=CurrType; Arguments[i].VDouble:=PDouble(Params)^; inc(PDouble(Params)); end; else begin {$ifdef DEBUG_DISPATCH} writeln('DispatchInvoke: Got argument with type ',CurrType); {$endif DEBUG_DISPATCH} Arguments[i].VType:=CurrType; Arguments[i].VPointer:=PPointer(Params)^; inc(PPointer(Params)); end; end; end; end; dispparams.cArgs:=desc^.calldesc.argcount; dispparams.rgvarg:=pointer(Arguments); dispparams.cNamedArgs:=desc^.calldesc.namedargcount; dispparams.rgdispidNamedArgs:=@desc^.CallDesc.ArgTypes[desc^.CallDesc.ArgCount]; flags:=desc^.calldesc.calltype; case flags of DISPATCH_PROPERTYPUT: begin inc(dispparams.cNamedArgs); if (Arguments[0].VType and varTypeMask) = varDispatch then flags:=DISPATCH_PROPERTYPUTREF; dispidNamed:=DISPID_PROPERTYPUT; DispParams.rgdispidNamedArgs:=@dispidNamed; end; DISPATCH_METHOD: if assigned(res) and (desc^.calldesc.argcount=0) then flags:=DISPATCH_METHOD or DISPATCH_PROPERTYGET; end; invokeresult:=disp.Invoke( desc^.DispId, { DispID: LongInt; } GUID_NULL, { const iid : TGUID; } 0, { LocaleID : longint; } flags, { Flags: Word; } dispparams, { var params; } res,@exceptioninfo,nil { VarResult,ExcepInfo,ArgErr : pointer) } ); if invokeresult<>0 then DispatchInvokeError(invokeresult,exceptioninfo); if desc^.calldesc.argcount>Length(preallocateddata) then FreeMem(Arguments); end; { TTypedComObject } function TTypedComObject.GetClassInfo(out pptti: ITypeInfo): HResult;stdcall; begin Result:=S_OK; pptti:=TTypedComObjectFactory(factory).classinfo; end; { TTypedComObjectFactory } constructor TTypedComObjectFactory.Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID; AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle); var TypedName, TypedDescription, TypedVersion: WideString; ppTypeAttr: lpTYPEATTR; begin //TDB get name and description from typelib (check if this is a valid guid) OleCheck(AComServer.GetTypeLib.GetTypeInfoOfGuid(AClassID, FClassInfo)); //bug FPC 0010569 - http://msdn2.microsoft.com/en-us/library/ms221396(VS.85).aspx OleCheck(FClassInfo.GetDocumentation(-1, @TypedName, @TypedDescription, nil, nil)); FClassInfo.GetTypeAttr(ppTypeAttr); try FTypeInfoCount := ppTypeAttr^.cImplTypes; TypedVersion := ''; if (ppTypeAttr^.wMajorVerNum <> 0) or (ppTypeAttr^.wMinorVerNum <> 0) then begin TypedVersion := IntToStr(ppTypeAttr^.wMajorVerNum); if ppTypeAttr^.wMinorVerNum <> 0 then TypedVersion := TypedVersion + '.' + IntToStr(ppTypeAttr^.wMinorVerNum) end; finally FClassInfo.ReleaseTypeAttr(ppTypeAttr); end; inherited Create(AComServer, TypedComClass, AClassID, TypedName, TypedVersion, TypedDescription, AInstancing, AThreadingModel); end; function TTypedComObjectFactory.GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo; var index, ImplTypeFlags: Integer; RefType: HRefType; begin Result := nil; for index := 0 to FTypeInfoCount - 1 do begin OleCheck(ClassInfo.GetImplTypeFlags(index, ImplTypeFlags)); if ImplTypeFlags = TypeFlags then begin OleCheck(ClassInfo.GetRefTypeOfImplType(index, RefType)); OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result)); break; end; end; end; procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean); var ptla: PTLibAttr; begin if Instancing = ciInternal then Exit; if Register then begin inherited UpdateRegistry(Register); //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html //There seems to also be Version according to Process Monitor //http://technet.microsoft.com/en-us/sysinternals/bb896645.aspx if FComServer.TypeLib = nil then raise Exception.Create('TypeLib is not set!'); OleCheck(FComServer.TypeLib.GetLibAttr(ptla)); try CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib', '', GUIDToString(ptla^.GUID)); finally FComServer.TypeLib.ReleaseTLibAttr(ptla); end; end else begin DeleteRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib'); inherited UpdateRegistry(Register); end; end; { TAutoIntfObject } function TAutoIntfObject.GetTypeInfoCount(out count: longint): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.GetTypeInfoCount'); {$endif} count := 1; Result := S_OK; end; function TAutoIntfObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo ): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.GetTypeInfo: ', Index); {$endif} if Index <> 0 then Result := DISP_E_BADINDEX else begin ITypeInfo(TypeInfo) := fTypeInfo; Result := S_OK; end; end; function TAutoIntfObject.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid)); {$endif} //return typeinfo->GetIDsOfNames(names, n, dispids); Result := fTypeInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^); end; function TAutoIntfObject.Invoke(DispID: LongInt; const iid: TGUID; LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo, ArgErr: pointer): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid)); //WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid)); {$endif} if not IsEqualGUID(iid, GUID_NULL) then Result := DISP_E_UNKNOWNINTERFACE else // Function Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall; // Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^); Result := fTypeInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), VarResult, ExcepInfo, ArgErr); end; function TAutoIntfObject.InterfaceSupportsErrorInfo(const riid: TIID): HResult; StdCall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.InterfaceSupportsErrorInfo: ', GUIDToString(riid)); {$endif} if assigned(GetInterfaceEntry(riid)) then Result:=S_OK else Result:=S_FALSE; end; function TAutoIntfObject.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; var //Message: string; Handled: Integer; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.SafeCallException'); {$endif} Handled:=0; Result:=0; //TODO: DO WE NEED THIS ? //if assigned(ServerExceptionHandler) then // begin // if ExceptObject is Exception then // Message:=Exception(ExceptObject).Message; // // ServerExceptionHandler.OnException(ClassName,ExceptObject.ClassName, // Message,PtrInt(ExceptAddr),WideString(GUIDToString(FFactory.ErrorIID)), // FFactory.ProgID,Handled,Result); // end; if Handled=0 then Result:=HandleSafeCallException(ExceptObject,ExceptAddr,StringToGuid('{7C538328-8A75-4EC4-A02E-FB3B27FAA411}'), '',''); end; constructor TAutoIntfObject.Create(TypeLib: ITypeLib; const Guid: TGuid); begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.Create: ', GUIDToString(Guid)); {$endif} OleCheck(TypeLib.GetTypeInfoOfGuid(Guid, fTypeInfo)); OleCheck(QueryInterface(Guid, fInterfacePointer)); end; { TAutoObject } function TAutoObject.GetTypeInfoCount(out count: longint): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoObject.GetTypeInfoCount'); {$endif} count := 1; Result := S_OK; end; function TAutoObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo ): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.GetTypeInfo: ', Index); {$endif} if Index <> 0 then Result := DISP_E_BADINDEX else begin ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).ClassInfo; Result := S_OK; end; end; function TAutoObject.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid)); {$endif} //return typeinfo->GetIDsOfNames(names, n, dispids); Result := TAutoObjectFactory(Factory).ClassInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^); end; function TAutoObject.Invoke(DispID: LongInt; const iid: TGUID; LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo, ArgErr: pointer): HResult; stdcall; begin {$ifdef DEBUG_COM} if printcom then WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid)); //WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid)); {$endif} if not IsEqualGUID(iid, GUID_NULL) then Result := DISP_E_UNKNOWNINTERFACE else begin Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer( PtrUint(Self) + TAutoObjectFactory(Factory).DispIntfEntry^.IOffset), DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr); end; end; { TAutoObjectFactory } constructor TAutoObjectFactory.Create(AComServer: TComServerObject; AutoClass: TAutoClass; const AClassID: TGUID; AInstancing: TClassInstancing; AThreadingModel: TThreadingModel); var ppTypeAttr: lpTYPEATTR; begin inherited Create(AComServer, AutoClass, AClassID, AInstancing, AThreadingModel); FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT); OleCheck(FDispTypeInfo.GetTypeAttr(ppTypeAttr)); try FDispIntfEntry := GetIntfEntry(ppTypeAttr^.guid); finally FDispTypeInfo.ReleaseTypeAttr(ppTypeAttr); end; end; function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry; begin Result := FComClass.GetInterfaceEntry(Guid); end; procedure TOleStream.Check(err:integer); begin OleCheck(err); end; const Initialized : boolean = false; var Ole32Dll : HModule; initialization Uninitializing:=false; _ComClassManager:=nil; Ole32Dll:=GetModuleHandle('ole32.dll'); if Ole32Dll<>0 then begin Pointer(CoCreateInstanceEx):=GetProcAddress(Ole32Dll,'CoCreateInstanceEx'); Pointer(CoInitializeEx):=GetProcAddress(Ole32Dll,'CoInitializeEx'); Pointer(CoAddRefServerProcess):=GetProcAddress(Ole32Dll,'CoAddRefServerProcess'); Pointer(CoReleaseServerProcess):=GetProcAddress(Ole32Dll,'CoReleaseServerProcess'); Pointer(CoResumeClassObjects):=GetProcAddress(Ole32Dll,'CoResumeClassObjects'); Pointer(CoSuspendClassObjects):=GetProcAddress(Ole32Dll,'CoSuspendClassObjects'); end; if not(IsLibrary) then {$ifndef wince} if (CoInitFlags=-1) or not(assigned(comobj.CoInitializeEx)) then Initialized:=Succeeded(CoInitialize(nil)) else {$endif wince} Initialized:=Succeeded(comobj.CoInitializeEx(nil, CoInitFlags)); SafeCallErrorProc:=@SafeCallErrorHandler; VarDispProc:=@ComObjDispatchInvoke; DispCallByIDProc:=@DoDispCallByID; finalization Uninitializing:=true; _ComClassManager.Free; VarDispProc:=nil; SafeCallErrorProc:=nil; if Initialized then CoUninitialize; end.