View Issue Details

IDProjectCategoryView StatusLast Update
0035013FPCRTLpublic2019-08-26 08:12
ReporterAnton KavalenkaAssigned ToMarco van de Voort 
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Platformi386OSWindowsOS Version
Product Version3.3.1Product Build 
Target VersionFixed in Version 
Summary0035013: Ole automation: COM server inside EXE is not usable
DescriptionBy default Ole automation used to control applications (exe modules) for specific task execution.
COM loads the server exe automatically or the Automation server is accessible when application (e.g. Word) is running.

Attached demo runs with D7 but not with FPC.

Test appropriate both for i386 and x86_64.
Steps To ReproduceThe attached program compiled with D7 works properly and registers itself as
LocalServer32

FPC-built exe assumes it is DLL and registers itself always as InprocServer32.

Something is missing in message handling - so TTestApp COM object is not created.

test.vbs is used for invoking ITestApp.test(bstr) method
TagsNo tags attached.
Fixed in Revision42594,42812
FPCOldBugId
FPCTarget-
Attached Files
  • oleaut.zip (3,371 bytes)
  • comobj.diff (4,193 bytes)
    --- C:/projects/fpc/packages/winunits-base/src/comobj.pp	�� ��� 24 01:06:36 2018
    +++ P:/fpctest/oleaut/comobj.pp	�� ��  7 15:16:48 2019
    @@ -25,7 +25,7 @@ unit ComObj;
       {$define DUMMY_REG}
     {$endif}
         uses
    -      Windows,Types,Variants,Sysutils,ActiveX,classes;
    +      Windows,Types,Variants,Sysutils,ActiveX,classes,hconst;
     
         type
           EOleError = class(Exception);
    @@ -159,11 +159,12 @@ unit ComObj;
             FErrorIID: TGUID;
             FInstancing: TClassInstancing;
             FLicString: WideString;
    -        //FRegister: Longint;
    +        FIsRegistered: dword;
             FShowErrors: Boolean;
             FSupportsLicensing: Boolean;
             FThreadingModel: TThreadingModel;
             function GetProgID: string;
    +        function reg_flags(): integer;
           protected
             { IUnknown }
             function QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall;
    @@ -937,8 +938,8 @@ implementation
              if printcom then 
             WriteLn('LockServer: ', fLock);
     {$endif}
    -        RunError(217);
    -        Result:=0;
    +          Result := CoLockObjectExternal(Self, fLock, True);
    +          ComServer.CountObject(fLock);
           end;
     
     
    @@ -1003,13 +1004,14 @@ implementation
             FComClass := ComClass;
             FInstancing := Instancing;;
             ComClassManager.AddObjectFactory(Self);
    +        fIsRegistered := dword(-1);
           end;
     
     
         destructor TComObjectFactory.Destroy;
           begin
    +        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
             ComClassManager.RemoveObjectFactory(Self);
    -        //RunError(217);
           end;
     
     
    @@ -1023,15 +1025,27 @@ implementation
             Result := TComClass(FComClass).Create();
           end;
     
    +    function TComObjectFactory.reg_flags():integer;inline;
    +    begin
    +       Result:=0;
    +       case Self.FInstancing of
    +       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
    +       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
    +       end;
    +       if FComServer.StartSuspended then
    +         Result:=Result or REGCLS_SUSPENDED;
    +    end;
     
         procedure TComObjectFactory.RegisterClassObject;
    -      begin
    +    begin
           {$ifdef DEBUG_COM}
              if printcom then 
             WriteLn('TComObjectFactory.RegisterClassObject');
           {$endif}
    -        RunError(217);
    -      end;
    +      if FInstancing <> ciInternal then
    +      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
    +         reg_flags(), @FIsRegistered));
    +    end;
     
     
     (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx)
    @@ -1066,6 +1080,7 @@ HKCR
         procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
           var
             classidguid: String;
    +        srv_type: string;
     
             function ThreadModelToString(model: TThreadingModel): String;
             begin
    @@ -1086,12 +1101,14 @@ HKCR
     {$endif}
             if Instancing = ciInternal then Exit;
     
    +        if System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
    +
             if Register then
             begin
               classidguid := GUIDToString(ClassID);
    -          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
    +          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
               //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
    -          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
    +          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, 'ThreadingModel', ThreadModelToString(ThreadingModel));
               CreateRegKey('CLSID\' + classidguid, '', Description);
               if ClassName <> '' then
               begin
    @@ -1115,7 +1132,7 @@ HKCR
             end else
             begin
               classidguid := GUIDToString(ClassID);
    -          DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
    +          DeleteRegKey('CLSID\' + classidguid + '\'+srv_type);
               DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
               if ClassName <> '' then
               begin
    
    comobj.diff (4,193 bytes)
  • comserv.diff (7,759 bytes)
    --- C:/projects/fpc/packages/winunits-base/src/comserv.pp	�� ��� 24 01:06:36 2018
    +++ P:/fpctest/oleaut/comserv.pp	�� ��  7 19:18:16 2019
    @@ -37,10 +37,13 @@ const
       SELFREG_E_CLASS = -2;
     
     type
    +  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
    +  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
     
       { TComServer }
     
       TComServer = class(TComServerObject)
    +  class var orgInitProc: codepointer;
       private
         fCountObject: Integer;
         fCountFactory: Integer;
    @@ -48,7 +51,23 @@ type
         fServerName,
         fServerFileName: String;
         fHelpFileName : String;
    +    fRegister: Boolean;
         fStartSuspended : Boolean;
    +    FIsInproc: Boolean;
    +    FIsInteractive: Boolean;
    +    FStartMode: TStartMode;
    +    FOnLastRelease: TLastReleaseEvent;
    +
    +    class function AutomationDone: Boolean;
    +    class procedure AutomationStart;
    +    procedure CheckCmdLine;
    +    procedure FactoryFree(Factory: TComObjectFactory);
    +    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
    +    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
    +    procedure CheckReleased;
    +    function GetTypeLibName: widestring;
    +    procedure RegisterObjectWith(Factory: TComObjectFactory);
    +    procedure Start;
       protected
         function CountObject(Created: Boolean): Integer; override;
         function CountFactory(Created: Boolean): Integer; override;
    @@ -69,11 +88,17 @@ type
         function CanUnloadNow: Boolean;
         procedure RegisterServer;
         procedure UnRegisterServer;
    +    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
    +    property IsInteractive: Boolean read fIsInteractive;
    +    property StartMode: TStartMode read FStartMode;
    +    property ServerObjects:integer read fCountObject;
       end;
     
     var
       ComServer: TComServer = nil;
    +  haut :TLibHandle;
     
    +
     //http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
     //If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
     function DllCanUnloadNow: HResult; stdcall;
    @@ -219,9 +244,24 @@ end;
     function TComServer.CountObject(Created: Boolean): Integer;
     begin
       if Created then
    -    Result:=InterLockedIncrement(fCountObject)
    +  begin
    +    Result := InterlockedIncrement(FCountObject);
    +    if (not IsInProcServer) and (StartMode = smAutomation)
    +      and Assigned(ComObj.CoAddRefServerProcess) then
    +      ComObj.CoAddRefServerProcess;
    +  end
       else
    -    Result:=InterLockedDecrement(fCountObject);
    +  begin
    +    Result := InterlockedDecrement(FCountObject);
    +    if (not IsInProcServer) and (StartMode = smAutomation)
    +      and Assigned(ComObj.CoReleaseServerProcess) then
    +    begin
    +      if ComObj.CoReleaseServerProcess() = 0 then
    +        CheckReleased;
    +    end
    +    else if Result = 0 then
    +      CheckReleased;
    +  end;
     end;
     
     function TComServer.CountFactory(Created: Boolean): Integer;
    @@ -232,6 +272,22 @@ begin
         Result:=InterLockedDecrement(fCountFactory);
     end;
     
    +procedure TComServer.FactoryFree(Factory: TComObjectFactory);
    +begin
    +  Factory.Free;
    +end;
    +
    +procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
    +begin
    +  Factory.RegisterClassObject;
    +end;
    +
    +procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
    +begin
    +  if Factory.Instancing <> ciInternal then
    +    Factory.UpdateRegistry(FRegister);
    +end;
    +
     function TComServer.GetHelpFileName: string;
     begin
       result:=fhelpfilename;
    @@ -244,14 +300,29 @@ end;
     
     function TComServer.GetServerKey: string;
     begin
    -  result:='LocalServer32';
    +  if FIsInproc then
    +    Result := 'InprocServer32'
    +  else
    +    Result := 'LocalServer32';
     end;
     
     function TComServer.GetServerName: string;
     begin
    -  Result := fServerName;
    +  if FServerName <> '' then
    +    Result := FServerName
    +  else
    +    if FTypeLib <> nil then
    +      Result := GetTypeLibName
    +    else
    +      Result := GetModuleName;
     end;
     
    +function TComServer.GetTypeLibName: widestring;
    +begin
    +  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
    +end;
    +
    +
     function TComServer.GetStartSuspended: Boolean;
     begin
       result:=fStartSuspended;
    @@ -262,6 +333,30 @@ begin
       Result := fTypeLib;
     end;
     
    +procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
    +begin
    +  Factory.RegisterClassObject;
    +end;
    +
    +
    +procedure TComServer.Start;
    +begin
    +  case fStartMode of
    +  smRegServer:
    +    begin
    +      Self.RegisterServer;
    +      Halt;
    +    end;
    +  smUnregServer:
    +    begin
    +      Self.UnRegisterServer;
    +      Halt;
    +    end;
    +  end;
    +  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
    +end;
    +
    +
     procedure TComServer.SetHelpFileName(const Value: string);
     begin
       FHelpFileName:=value;
    @@ -277,10 +372,25 @@ begin
       Factory.UpdateRegistry(False);
     end;
     
    +procedure TComServer.CheckCmdLine;
    +const
    +  sw_set:TSysCharSet = ['/','-'];
    +begin
    +  if FindCmdLineSwitch('automation',sw_set,true) or
    +     FindCmdLineSwitch('embedding',sw_set,true) then
    +    fStartMode := smAutomation
    +  else if FindCmdlIneSwitch('regserver',sw_set,true) then
    +    fStartMode := smRegServer
    +  else if FindCmdLineSwitch('unregserver',sw_set,true) then
    +    fStartMode := smUnregServer;
    +end;
    +
     constructor TComServer.Create;
     var
       name: WideString;
     begin
    +  haut := SafeLoadLibrary('oleaut32.DLL');
    +  CheckCmdLine;
       inherited Create;
     {$ifdef DEBUG_COM}
       WriteLn('TComServer.Create');
    @@ -288,6 +398,9 @@ begin
       fCountFactory := 0;
       fCountObject := 0;
     
    +  FTypeLib := nil;
    +  FIsInproc := ModuleIsLib;
    +
       fServerFileName := GetModuleFileName();
     
       name := fServerFileName;
    @@ -301,11 +414,60 @@ begin
       end
       else
         fServerName := GetModuleName;
    +
    +  if not ModuleIsLib then
    +  begin
    +    orgInitProc := InitProc;
    +    InitProc := @TComServer.AutomationStart;
    +    AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
    +  end;
    +
    +  Self.FIsInteractive := True;
     end;
     
    +class procedure TComServer.AutomationStart;
    +begin
    +  if orgInitProc <> nil then TProcedure(orgInitProc)();
    +  ComServer.FStartSuspended := (CoInitFlags <> -1) and
    +    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
    +  ComServer.Start;
    +  if ComServer.FStartSuspended then
    +    ComObj.CoResumeClassObjects;
    +end;
    +
    +class function TComServer.AutomationDone: Boolean;
    +begin
    +  Result := True;
    +  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
    +  begin
    +    Result := MessageBox(0, PChar('COM server is in use'),
    +      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
    +      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
    +  end;
    +end;
    +
    +
    +procedure TComServer.CheckReleased;
    +var
    +  Shutdown: Boolean;
    +begin
    +  if not FIsInproc then
    +  begin
    +    Shutdown := FStartMode = smAutomation;
    +    try
    +      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
    +    finally
    +      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
    +    end;
    +  end;
    +end;
    +
    +
     destructor TComServer.Destroy;
     begin
    +  ComClassManager.ForEachFactory(Self, @FactoryFree);
       inherited Destroy;
    +  FreeLibrary(haut);
     {$ifdef DEBUG_COM}
       WriteLn('TComServer.Destroy');
     {$endif}
    @@ -332,15 +494,17 @@ begin
       ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
     end;
     
    +
     initialization
     {$ifdef DEBUG_COM}
       WriteLn('comserv initialization begin');
     {$endif}
       ComServer := TComServer.Create;
    +
     {$ifdef DEBUG_COM}
       WriteLn('comserv initialization end');
     {$endif}
     finalization
    -  ComServer.Free;
    +  FreeAndNil(ComServer);
     end.
     
    
    comserv.diff (7,759 bytes)
  • oleaut1.zip (1,943 bytes)
  • comobj-2.diff (137,245 bytes)
    --- P:/ulinuxg/comobj.pp	�� ˳� 19 16:24:56 2019
    +++ P:/fpc/packages/winunits-base/src/comobj.pp	�� ��� 30 18:32:21 2018
    @@ -1,1903 +1,1878 @@
    -{
    -    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;const bBackward:boolean=false);
    -        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;
    -        FIsRegistered: dword;
    -        FShowErrors: Boolean;
    -        FSupportsLicensing: Boolean;
    -        FThreadingModel: TThreadingModel;
    -        function GetProgID: string;
    -        function reg_flags(): integer;
    -      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;
    -
    -    function StringToLPOLESTR(const Source: string): POLEStr;
    -
    -    procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
    -    procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
    -
    -    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;
    -
    -
    -   function StringToLPOLESTR(const Source: string): POLEStr;
    -     var
    -       Src: WideString;
    -     begin
    -       Src := WideString(Source);
    -       Result := CoTaskMemAlloc((Length(Src)+1) * SizeOf(WideChar));
    -       if Result <> nil then
    -         Move(PWideChar(Src)^, Result^, (Length(Src)+1) * SizeOf(WideChar));
    -     end;
    -
    -
    -   procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
    -     var
    -       CPC: IConnectionPointContainer;
    -       CP: IConnectionPoint;
    -       i: hresult;
    -     begin
    -       Connection := 0;
    -       if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
    -         if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
    -           i:=CP.Advise(Sink, Connection);
    -     end;
    -
    -
    -   procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
    -     var
    -       CPC: IConnectionPointContainer;
    -       CP: IConnectionPoint;
    -       i: hresult;
    -     begin
    -       if Connection <> 0 then
    -         if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
    -           if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
    -           begin
    -             i:=CP.Unadvise(Connection);
    -             if Succeeded(i) then Connection := 0;
    -           end;
    -     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;const bBackward:boolean=false);
    -      var
    -        i: Integer;
    -        obj: TComObjectFactory;
    -      begin
    -{$ifdef DEBUG_COM}
    -         if printcom then 
    -        WriteLn('ForEachFactory');
    -{$endif}
    -        if not bBackward then
    -        for i := 0 to fClassFactoryList.Count - 1 do
    -        begin
    -          obj := TComObjectFactory(fClassFactoryList[i]);
    -          if obj.ComServer = ComServer then
    -            FactoryProc(obj);
    -        end
    -        else
    -        for i := fClassFactoryList.Count - 1 downto 0 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}
    -          Result := CoLockObjectExternal(Self, fLock, True);
    -          ComServer.CountObject(fLock);
    -      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);
    -        fIsRegistered := dword(-1);
    -      end;
    -
    -
    -    destructor TComObjectFactory.Destroy;
    -      begin
    -        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
    -        ComClassManager.RemoveObjectFactory(Self);
    -      end;
    -
    -
    -    function TComObjectFactory.CreateComObject(const Controller: IUnknown
    -      ): TComObject;
    -      begin
    -{$ifdef DEBUG_COM}
    -         if printcom then 
    -        WriteLn('TComObjectFactory.CreateComObject');
    -{$endif}
    -        Result := TComClass(FComClass).Create();
    -      end;
    -
    -    function TComObjectFactory.reg_flags():integer;inline;
    -    begin
    -       Result:=0;
    -       case Self.FInstancing of
    -       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
    -       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
    -       end;
    -       if FComServer.StartSuspended then
    -         Result:=Result or REGCLS_SUSPENDED;
    -    end;
    -
    -    procedure TComObjectFactory.RegisterClassObject;
    -    begin
    -      {$ifdef DEBUG_COM}
    -         if printcom then 
    -        WriteLn('TComObjectFactory.RegisterClassObject');
    -      {$endif}
    -      if FInstancing <> ciInternal then
    -      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
    -         reg_flags(), @FIsRegistered));
    -    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;
    -        srv_type: 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 System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
    -
    -        if Register then
    -        begin
    -          classidguid := GUIDToString(ClassID);
    -          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
    -          //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
    -          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '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 + '\'+srv_type);
    -          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:
    -              { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
    -                flags for anything returning a result, see bug #24352 }
    -              if assigned(Result) 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:
    -            { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
    -              flags for anything returning a result, see bug #24352 }
    -            if assigned(res) 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.
    -
    +{
    +    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;
    +
    +    function StringToLPOLESTR(const Source: string): POLEStr;
    +
    +    procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
    +    procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
    +
    +    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;
    +
    +
    +   function StringToLPOLESTR(const Source: string): POLEStr;
    +     var
    +       Src: WideString;
    +     begin
    +       Src := WideString(Source);
    +       Result := CoTaskMemAlloc((Length(Src)+1) * SizeOf(WideChar));
    +       if Result <> nil then
    +         Move(PWideChar(Src)^, Result^, (Length(Src)+1) * SizeOf(WideChar));
    +     end;
    +
    +
    +   procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
    +     var
    +       CPC: IConnectionPointContainer;
    +       CP: IConnectionPoint;
    +       i: hresult;
    +     begin
    +       Connection := 0;
    +       if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
    +         if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
    +           i:=CP.Advise(Sink, Connection);
    +     end;
    +
    +
    +   procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
    +     var
    +       CPC: IConnectionPointContainer;
    +       CP: IConnectionPoint;
    +       i: hresult;
    +     begin
    +       if Connection <> 0 then
    +         if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
    +           if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
    +           begin
    +             i:=CP.Unadvise(Connection);
    +             if Succeeded(i) then Connection := 0;
    +           end;
    +     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:
    +              { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
    +                flags for anything returning a result, see bug #24352 }
    +              if assigned(Result) 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:
    +            { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
    +              flags for anything returning a result, see bug #24352 }
    +            if assigned(res) 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.
    +
    
    comobj-2.diff (137,245 bytes)
  • comserv-2.diff (22,872 bytes)
    --- P:/ulinuxg/comserv.pp	�� ˳� 19 16:32:01 2019
    +++ P:/fpc/packages/winunits-base/src/comserv.pp	�� ��� 30 18:32:21 2018
    @@ -1,512 +1,346 @@
    -{
    -    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 ComServ;
    -
    -interface
    -
    -uses
    -  Classes, SysUtils, comobj, ActiveX;
    -
    -{ $define DEBUG_COM}
    -
    -//according to doc
    -// * ComServer Variable
    -// * DllCanUnloadNow Routine
    -// * DllGetClassObject Routine
    -// * DllRegisterServer Routine
    -// * DllUnregisterServer Routine
    -// * TComServer Class
    -
    -//TODO Fix this
    -const
    -  CLASS_E_CLASSNOTAVAILABLE = -1;
    -  SELFREG_E_CLASS = -2;
    -
    -type
    -  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
    -  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
    -
    -  { TComServer }
    -
    -  TComServer = class(TComServerObject)
    -  class var orgInitProc: codepointer;
    -  private
    -    fCountObject: Integer;
    -    fCountFactory: Integer;
    -    fTypeLib: ITypeLib;
    -    fServerName,
    -    fServerFileName: String;
    -    fHelpFileName : String;
    -    fRegister: Boolean;
    -    fStartSuspended : Boolean;
    -    FIsInproc: Boolean;
    -    FIsInteractive: Boolean;
    -    FStartMode: TStartMode;
    -    FOnLastRelease: TLastReleaseEvent;
    -
    -    class function AutomationDone: Boolean;
    -    class procedure AutomationStart;
    -    procedure CheckCmdLine;
    -    procedure FactoryFree(Factory: TComObjectFactory);
    -    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
    -    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
    -    procedure CheckReleased;
    -    function GetTypeLibName: widestring;
    -    procedure RegisterObjectWith(Factory: TComObjectFactory);
    -    procedure Start;
    -  protected
    -    function CountObject(Created: Boolean): Integer; override;
    -    function CountFactory(Created: Boolean): Integer; override;
    -    function GetHelpFileName: string; override;
    -    function GetServerFileName: string; override;
    -    function GetServerKey: string; override;
    -    function GetServerName: string; override;
    -    function GetStartSuspended: Boolean; override;
    -    function GetTypeLib: ITypeLib; override;
    -    procedure SetHelpFileName(const Value: string); override;
    -
    -
    -    procedure RegisterServerFactory(Factory: TComObjectFactory);
    -    procedure UnregisterServerFactory(Factory: TComObjectFactory);
    -  public
    -    constructor Create;
    -    destructor Destroy; override;
    -    function CanUnloadNow: Boolean;
    -    procedure RegisterServer;
    -    procedure UnRegisterServer;
    -    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
    -    property IsInteractive: Boolean read fIsInteractive;
    -    property StartMode: TStartMode read FStartMode;
    -    property ServerObjects:integer read fCountObject;
    -  end;
    -
    -var
    -  ComServer: TComServer = nil;
    -  haut :TLibHandle;
    -
    -
    -//http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
    -//If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
    -function DllCanUnloadNow: HResult; stdcall;
    -
    -
    -//S_OK - The object was retrieved successfully.
    -//CLASS_E_CLASSNOTAVAILABLE - The DLL does not support the class (object definition).
    -function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
    -
    -//S_OK - The registry entries were created successfully.
    -//SELFREG_E_TYPELIB - The server was unable to complete the registration of all the type libraries used by its classes.
    -//SELFREG_E_CLASS - The server was unable to complete the registration of all the object classes.
    -function DllRegisterServer: HResult; stdcall;
    -
    -//S_OK - The registry entries were deleted successfully.
    -//S_FALSE - Unregistration of this server's known entries was successful, but other entries still exist for this server's classes.
    -//SELFREG_E_TYPELIB - The server was unable to remove the entries of all the type libraries used by its classes.
    -//SELFREG_E_CLASS - The server was unable to remove the entries of all the object classes.
    -function DllUnregisterServer: HResult; stdcall;
    -
    -implementation
    -
    -uses
    -  Windows;
    -
    -function DllCanUnloadNow: HResult; stdcall;
    -begin
    -{$ifdef DEBUG_COM}
    -  WriteLn('DllCanUnloadNow called');
    -{$endif}
    -  if ComServer.CanUnloadNow then
    -    Result := S_OK
    -  else
    -    Result := S_FALSE;
    -{$ifdef DEBUG_COM}
    -    WriteLn('DllCanUnloadNow return: ', Result);
    -{$endif}
    -end;
    -
    -(*
    -    //FROM MSDN (Error messages are different in MSDN.DllGetClassObject)
    -
    -    HRESULT hres = E_OUTOFMEMORY;
    -    *ppvObj = NULL;
    -
    -    CClassFactory *pClassFactory = new CClassFactory(rclsid);
    -    if (pClassFactory != NULL)   {
    -        hRes = pClassFactory->QueryInterface(riid, ppvObj);
    -        pClassFactory->Release();
    -    }
    -    return hRes;
    -*)
    -
    -function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
    -var
    -  factory: TComObjectFactory;
    -begin
    -{$ifdef DEBUG_COM}
    -  WriteLn('DllGetClassObject called: ', GUIDToString(rclsid), ' ', GUIDToString(riid));
    -{$endif}
    -
    -  factory := ComClassManager.GetFactoryFromClassID(rclsid);
    -  if factory = nil then
    -    Result := CLASS_E_CLASSNOTAVAILABLE
    -  else
    -  begin
    -    if factory.GetInterface(riid,ppv) then
    -      Result := S_OK
    -    else
    -      Result := CLASS_E_CLASSNOTAVAILABLE;
    -{$ifdef DEBUG_COM}
    -    WriteLn('DllGetClassObject return: ', Result);
    -{$endif}
    -  end;
    -end;
    -
    -function DllRegisterServer: HResult; stdcall;
    -begin
    -{$ifdef DEBUG_COM}
    -  WriteLn('DllRegisterServer called');
    -{$endif}
    -  try
    -    ComServer.RegisterServer;
    -    Result := S_OK;
    -  except
    -    Result := SELFREG_E_CLASS;
    -  end;
    -
    -end;
    -
    -function DllUnregisterServer: HResult; stdcall;
    -begin
    -{$ifdef DEBUG_COM}
    -  WriteLn('DllUnregisterServer called');
    -{$endif}
    -  try
    -    ComServer.UnregisterServer;
    -    Result := S_OK;
    -  except
    -    Result := SELFREG_E_CLASS;
    -  end;
    -end;
    -
    -function GetModuleFileName: String;
    -const
    -  MAX_PATH_SIZE = 2048;
    -begin
    -  SetLength(Result, MAX_PATH_SIZE);
    -  SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
    -end;
    -
    -function GetModuleName: String;
    -begin
    -  Result := ExtractFileName(GetModuleFileName);
    -  Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
    -end;
    -
    -procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
    -var
    -  FullPath: WideString;
    -begin
    -  FullPath := ModuleName;
    -  //according to MSDN helpdir can be null
    -  OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
    -end;
    -
    -procedure UnRegisterTypeLib(TypeLib: ITypeLib);
    -var
    -  ptla: PTLibAttr;
    -begin
    -  //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
    -  OleCheck(TypeLib.GetLibAttr(ptla));
    -  try
    -    ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind);
    -  finally
    -    TypeLib.ReleaseTLibAttr(ptla);
    -  end;
    -end;
    -
    -
    -{ TComServer }
    -
    -function TComServer.CountObject(Created: Boolean): Integer;
    -begin
    -  if Created then
    -  begin
    -    Result := InterlockedIncrement(FCountObject);
    -    if (not IsInProcServer) and (StartMode = smAutomation)
    -      and Assigned(ComObj.CoAddRefServerProcess) then
    -      ComObj.CoAddRefServerProcess;
    -  end
    -  else
    -  begin
    -    Result := InterlockedDecrement(FCountObject);
    -    if (not IsInProcServer) and (StartMode = smAutomation)
    -      and Assigned(ComObj.CoReleaseServerProcess) then
    -    begin
    -      if ComObj.CoReleaseServerProcess() = 0 then
    -        CheckReleased;
    -    end
    -    else if Result = 0 then
    -      CheckReleased;
    -  end;
    -end;
    -
    -function TComServer.CountFactory(Created: Boolean): Integer;
    -begin
    -  if Created then
    -    Result:=InterLockedIncrement(fCountFactory)
    -  else
    -    Result:=InterLockedDecrement(fCountFactory);
    -end;
    -
    -procedure TComServer.FactoryFree(Factory: TComObjectFactory);
    -begin
    -  Factory.Free;
    -end;
    -
    -procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
    -begin
    -  Factory.RegisterClassObject;
    -end;
    -
    -procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
    -begin
    -  if Factory.Instancing <> ciInternal then
    -    Factory.UpdateRegistry(FRegister);
    -end;
    -
    -function TComServer.GetHelpFileName: string;
    -begin
    -  result:=fhelpfilename;
    -end;
    -
    -function TComServer.GetServerFileName: string;
    -begin
    -  Result := fServerFileName;
    -end;
    -
    -function TComServer.GetServerKey: string;
    -begin
    -  if FIsInproc then
    -    Result := 'InprocServer32'
    -  else
    -    Result := 'LocalServer32';
    -end;
    -
    -function TComServer.GetServerName: string;
    -begin
    -  if FServerName <> '' then
    -    Result := FServerName
    -  else
    -    if FTypeLib <> nil then
    -      Result := GetTypeLibName
    -    else
    -      Result := GetModuleName;
    -end;
    -
    -function TComServer.GetTypeLibName: widestring;
    -begin
    -  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
    -end;
    -
    -
    -function TComServer.GetStartSuspended: Boolean;
    -begin
    -  result:=fStartSuspended;
    -end;
    -
    -function TComServer.GetTypeLib: ITypeLib;
    -begin
    -  Result := fTypeLib;
    -end;
    -
    -procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
    -begin
    -  Factory.RegisterClassObject;
    -end;
    -
    -
    -procedure TComServer.Start;
    -begin
    -  case fStartMode of
    -  smRegServer:
    -    begin
    -      Self.RegisterServer;
    -      Halt;
    -    end;
    -  smUnregServer:
    -    begin
    -      Self.UnRegisterServer;
    -      Halt;
    -    end;
    -  end;
    -  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
    -end;
    -
    -
    -procedure TComServer.SetHelpFileName(const Value: string);
    -begin
    -  FHelpFileName:=value;
    -end;
    -
    -procedure TComServer.RegisterServerFactory(Factory: TComObjectFactory);
    -begin
    -  Factory.UpdateRegistry(True);
    -end;
    -
    -procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
    -begin
    -  Factory.UpdateRegistry(False);
    -end;
    -
    -procedure TComServer.CheckCmdLine;
    -const
    -  sw_set:TSysCharSet = ['/','-'];
    -begin
    -  if FindCmdLineSwitch('automation',sw_set,true) or
    -     FindCmdLineSwitch('embedding',sw_set,true) then
    -    fStartMode := smAutomation
    -  else if FindCmdlIneSwitch('regserver',sw_set,true) then
    -    fStartMode := smRegServer
    -  else if FindCmdLineSwitch('unregserver',sw_set,true) then
    -    fStartMode := smUnregServer;
    -end;
    -
    -constructor TComServer.Create;
    -var
    -  name: WideString;
    -begin
    -  haut := SafeLoadLibrary('oleaut32.DLL');
    -  CheckCmdLine;
    -  inherited Create;
    -{$ifdef DEBUG_COM}
    -  WriteLn('TComServer.Create');
    -{$endif}
    -  fCountFactory := 0;
    -  fCountObject := 0;
    -
    -  FTypeLib := nil;
    -  FIsInproc := ModuleIsLib;
    -
    -  fServerFileName := GetModuleFileName();
    -
    -  name := fServerFileName;
    -  if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
    -    fTypeLib := nil;
    -
    -  if FTypeLib <> nil then
    -  begin
    -    fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
    -    fServerName := name;
    -  end
    -  else
    -    fServerName := GetModuleName;
    -
    -  if not ModuleIsLib then
    -  begin
    -    orgInitProc := InitProc;
    -    InitProc := @TComServer.AutomationStart;
    -  //  AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
    -  end;
    -
    -  Self.FIsInteractive := True;
    -end;
    -
    -class procedure TComServer.AutomationStart;
    -begin
    -  if orgInitProc <> nil then TProcedure(orgInitProc)();
    -  ComServer.FStartSuspended := (CoInitFlags <> -1) and
    -    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
    -  ComServer.Start;
    -  if ComServer.FStartSuspended then
    -    ComObj.CoResumeClassObjects;
    -end;
    -
    -class function TComServer.AutomationDone: Boolean;
    -begin
    -  Result := True;
    -  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
    -  begin
    -    Result := MessageBox(0, PChar('COM server is in use'),
    -      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
    -      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
    -  end;
    -end;
    -
    -
    -procedure TComServer.CheckReleased;
    -var
    -  Shutdown: Boolean;
    -begin
    -  if not FIsInproc then
    -  begin
    -    Shutdown := FStartMode = smAutomation;
    -    try
    -      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
    -    finally
    -      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
    -    end;
    -  end;
    -end;
    -
    -
    -destructor TComServer.Destroy;
    -begin
    -  ComClassManager.ForEachFactory(Self, @FactoryFree,true);
    -  Self.fTypeLib:=nil;
    -  inherited Destroy;
    -  FreeLibrary(haut);
    -{$ifdef DEBUG_COM}
    -  WriteLn('TComServer.Destroy');
    -{$endif}
    -end;
    -
    -function TComServer.CanUnloadNow: Boolean;
    -begin
    -  Result := False;
    -end;
    -
    -procedure TComServer.RegisterServer;
    -begin
    -  if fTypeLib <> nil then
    -    RegisterTypeLib(fTypeLib, fServerFileName);
    -
    -  ComClassManager.ForEachFactory(self, @RegisterServerFactory);
    -end;
    -
    -procedure TComServer.UnRegisterServer;
    -begin
    -  if fTypeLib <> nil then
    -    UnRegisterTypeLib(fTypeLib);
    -
    -  ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
    -end;
    -
    -
    -initialization
    -{$ifdef DEBUG_COM}
    -  WriteLn('comserv initialization begin');
    -{$endif}
    -  ComServer := TComServer.Create;
    -
    -{$ifdef DEBUG_COM}
    -  WriteLn('comserv initialization end');
    -{$endif}
    -finalization
    -  ComServer.AutomationDone;
    -  FreeAndNil(ComServer);
    -end.
    -
    +{
    +    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 ComServ;
    +
    +interface
    +
    +uses
    +  Classes, SysUtils, comobj, ActiveX;
    +
    +{ $define DEBUG_COM}
    +
    +//according to doc
    +// * ComServer Variable
    +// * DllCanUnloadNow Routine
    +// * DllGetClassObject Routine
    +// * DllRegisterServer Routine
    +// * DllUnregisterServer Routine
    +// * TComServer Class
    +
    +//TODO Fix this
    +const
    +  CLASS_E_CLASSNOTAVAILABLE = -1;
    +  SELFREG_E_CLASS = -2;
    +
    +type
    +
    +  { TComServer }
    +
    +  TComServer = class(TComServerObject)
    +  private
    +    fCountObject: Integer;
    +    fCountFactory: Integer;
    +    fTypeLib: ITypeLib;
    +    fServerName,
    +    fServerFileName: String;
    +    fHelpFileName : String;
    +    fStartSuspended : Boolean;
    +  protected
    +    function CountObject(Created: Boolean): Integer; override;
    +    function CountFactory(Created: Boolean): Integer; override;
    +    function GetHelpFileName: string; override;
    +    function GetServerFileName: string; override;
    +    function GetServerKey: string; override;
    +    function GetServerName: string; override;
    +    function GetStartSuspended: Boolean; override;
    +    function GetTypeLib: ITypeLib; override;
    +    procedure SetHelpFileName(const Value: string); override;
    +
    +
    +    procedure RegisterServerFactory(Factory: TComObjectFactory);
    +    procedure UnregisterServerFactory(Factory: TComObjectFactory);
    +  public
    +    constructor Create;
    +    destructor Destroy; override;
    +    function CanUnloadNow: Boolean;
    +    procedure RegisterServer;
    +    procedure UnRegisterServer;
    +  end;
    +
    +var
    +  ComServer: TComServer = nil;
    +
    +//http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
    +//If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
    +function DllCanUnloadNow: HResult; stdcall;
    +
    +
    +//S_OK - The object was retrieved successfully.
    +//CLASS_E_CLASSNOTAVAILABLE - The DLL does not support the class (object definition).
    +function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
    +
    +//S_OK - The registry entries were created successfully.
    +//SELFREG_E_TYPELIB - The server was unable to complete the registration of all the type libraries used by its classes.
    +//SELFREG_E_CLASS - The server was unable to complete the registration of all the object classes.
    +function DllRegisterServer: HResult; stdcall;
    +
    +//S_OK - The registry entries were deleted successfully.
    +//S_FALSE - Unregistration of this server's known entries was successful, but other entries still exist for this server's classes.
    +//SELFREG_E_TYPELIB - The server was unable to remove the entries of all the type libraries used by its classes.
    +//SELFREG_E_CLASS - The server was unable to remove the entries of all the object classes.
    +function DllUnregisterServer: HResult; stdcall;
    +
    +implementation
    +
    +uses
    +  Windows;
    +
    +function DllCanUnloadNow: HResult; stdcall;
    +begin
    +{$ifdef DEBUG_COM}
    +  WriteLn('DllCanUnloadNow called');
    +{$endif}
    +  if ComServer.CanUnloadNow then
    +    Result := S_OK
    +  else
    +    Result := S_FALSE;
    +{$ifdef DEBUG_COM}
    +    WriteLn('DllCanUnloadNow return: ', Result);
    +{$endif}
    +end;
    +
    +(*
    +    //FROM MSDN (Error messages are different in MSDN.DllGetClassObject)
    +
    +    HRESULT hres = E_OUTOFMEMORY;
    +    *ppvObj = NULL;
    +
    +    CClassFactory *pClassFactory = new CClassFactory(rclsid);
    +    if (pClassFactory != NULL)   {
    +        hRes = pClassFactory->QueryInterface(riid, ppvObj);
    +        pClassFactory->Release();
    +    }
    +    return hRes;
    +*)
    +
    +function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
    +var
    +  factory: TComObjectFactory;
    +begin
    +{$ifdef DEBUG_COM}
    +  WriteLn('DllGetClassObject called: ', GUIDToString(rclsid), ' ', GUIDToString(riid));
    +{$endif}
    +
    +  factory := ComClassManager.GetFactoryFromClassID(rclsid);
    +  if factory = nil then
    +    Result := CLASS_E_CLASSNOTAVAILABLE
    +  else
    +  begin
    +    if factory.GetInterface(riid,ppv) then
    +      Result := S_OK
    +    else
    +      Result := CLASS_E_CLASSNOTAVAILABLE;
    +{$ifdef DEBUG_COM}
    +    WriteLn('DllGetClassObject return: ', Result);
    +{$endif}
    +  end;
    +end;
    +
    +function DllRegisterServer: HResult; stdcall;
    +begin
    +{$ifdef DEBUG_COM}
    +  WriteLn('DllRegisterServer called');
    +{$endif}
    +  try
    +    ComServer.RegisterServer;
    +    Result := S_OK;
    +  except
    +    Result := SELFREG_E_CLASS;
    +  end;
    +
    +end;
    +
    +function DllUnregisterServer: HResult; stdcall;
    +begin
    +{$ifdef DEBUG_COM}
    +  WriteLn('DllUnregisterServer called');
    +{$endif}
    +  try
    +    ComServer.UnregisterServer;
    +    Result := S_OK;
    +  except
    +    Result := SELFREG_E_CLASS;
    +  end;
    +end;
    +
    +function GetModuleFileName: String;
    +const
    +  MAX_PATH_SIZE = 2048;
    +begin
    +  SetLength(Result, MAX_PATH_SIZE);
    +  SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
    +end;
    +
    +function GetModuleName: String;
    +begin
    +  Result := ExtractFileName(GetModuleFileName);
    +  Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
    +end;
    +
    +procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
    +var
    +  FullPath: WideString;
    +begin
    +  FullPath := ModuleName;
    +  //according to MSDN helpdir can be null
    +  OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
    +end;
    +
    +procedure UnRegisterTypeLib(TypeLib: ITypeLib);
    +var
    +  ptla: PTLibAttr;
    +begin
    +  //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
    +  OleCheck(TypeLib.GetLibAttr(ptla));
    +  try
    +    ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind);
    +  finally
    +    TypeLib.ReleaseTLibAttr(ptla);
    +  end;
    +end;
    +
    +
    +{ TComServer }
    +
    +function TComServer.CountObject(Created: Boolean): Integer;
    +begin
    +  if Created then
    +    Result:=InterLockedIncrement(fCountObject)
    +  else
    +    Result:=InterLockedDecrement(fCountObject);
    +end;
    +
    +function TComServer.CountFactory(Created: Boolean): Integer;
    +begin
    +  if Created then
    +    Result:=InterLockedIncrement(fCountFactory)
    +  else
    +    Result:=InterLockedDecrement(fCountFactory);
    +end;
    +
    +function TComServer.GetHelpFileName: string;
    +begin
    +  result:=fhelpfilename;
    +end;
    +
    +function TComServer.GetServerFileName: string;
    +begin
    +  Result := fServerFileName;
    +end;
    +
    +function TComServer.GetServerKey: string;
    +begin
    +  result:='LocalServer32';
    +end;
    +
    +function TComServer.GetServerName: string;
    +begin
    +  Result := fServerName;
    +end;
    +
    +function TComServer.GetStartSuspended: Boolean;
    +begin
    +  result:=fStartSuspended;
    +end;
    +
    +function TComServer.GetTypeLib: ITypeLib;
    +begin
    +  Result := fTypeLib;
    +end;
    +
    +procedure TComServer.SetHelpFileName(const Value: string);
    +begin
    +  FHelpFileName:=value;
    +end;
    +
    +procedure TComServer.RegisterServerFactory(Factory: TComObjectFactory);
    +begin
    +  Factory.UpdateRegistry(True);
    +end;
    +
    +procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
    +begin
    +  Factory.UpdateRegistry(False);
    +end;
    +
    +constructor TComServer.Create;
    +var
    +  name: WideString;
    +begin
    +  inherited Create;
    +{$ifdef DEBUG_COM}
    +  WriteLn('TComServer.Create');
    +{$endif}
    +  fCountFactory := 0;
    +  fCountObject := 0;
    +
    +  fServerFileName := GetModuleFileName();
    +
    +  name := fServerFileName;
    +  if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
    +    fTypeLib := nil;
    +
    +  if FTypeLib <> nil then
    +  begin
    +    fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
    +    fServerName := name;
    +  end
    +  else
    +    fServerName := GetModuleName;
    +end;
    +
    +destructor TComServer.Destroy;
    +begin
    +  inherited Destroy;
    +{$ifdef DEBUG_COM}
    +  WriteLn('TComServer.Destroy');
    +{$endif}
    +end;
    +
    +function TComServer.CanUnloadNow: Boolean;
    +begin
    +  Result := False;
    +end;
    +
    +procedure TComServer.RegisterServer;
    +begin
    +  if fTypeLib <> nil then
    +    RegisterTypeLib(fTypeLib, fServerFileName);
    +
    +  ComClassManager.ForEachFactory(self, @RegisterServerFactory);
    +end;
    +
    +procedure TComServer.UnRegisterServer;
    +begin
    +  if fTypeLib <> nil then
    +    UnRegisterTypeLib(fTypeLib);
    +
    +  ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
    +end;
    +
    +initialization
    +{$ifdef DEBUG_COM}
    +  WriteLn('comserv initialization begin');
    +{$endif}
    +  ComServer := TComServer.Create;
    +{$ifdef DEBUG_COM}
    +  WriteLn('comserv initialization end');
    +{$endif}
    +finalization
    +  ComServer.Free;
    +end.
    +
    
    comserv-2.diff (22,872 bytes)
  • 35013.patch (12,969 bytes)
    Index: packages/winunits-base/src/comobj.pp
    ===================================================================
    --- packages/winunits-base/src/comobj.pp	(revision 42475)
    +++ packages/winunits-base/src/comobj.pp	(working copy)
    @@ -92,7 +92,7 @@
             destructor Destroy; override;
             procedure AddObjectFactory(factory: TComObjectFactory);
             procedure RemoveObjectFactory(factory: TComObjectFactory);
    -        procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc);
    +        procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc;const bBackward:boolean=false);
             function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
             function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
           end;
    @@ -159,11 +159,12 @@
             FErrorIID: TGUID;
             FInstancing: TClassInstancing;
             FLicString: WideString;
    -        //FRegister: Longint;
    +        FIsRegistered: dword;
             FShowErrors: Boolean;
             FSupportsLicensing: Boolean;
             FThreadingModel: TThreadingModel;
             function GetProgID: string;
    +        function reg_flags(): integer;
           protected
             { IUnknown }
             function QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall;
    @@ -694,7 +695,7 @@
           end;
     
         procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
    -      FactoryProc: TFactoryProc);
    +      FactoryProc: TFactoryProc;const bBackward:boolean=false);
           var
             i: Integer;
             obj: TComObjectFactory;
    @@ -703,12 +704,20 @@
              if printcom then 
             WriteLn('ForEachFactory');
     {$endif}
    +        if not bBackward then
             for i := 0 to fClassFactoryList.Count - 1 do
             begin
               obj := TComObjectFactory(fClassFactoryList[i]);
               if obj.ComServer = ComServer then
                 FactoryProc(obj);
    -        end;
    +        end
    +        else
    +        for i := fClassFactoryList.Count - 1 downto 0 do
    +        begin
    +          obj := TComObjectFactory(fClassFactoryList[i]);
    +          if obj.ComServer = ComServer then
    +            FactoryProc(obj);
    +        end
           end;
     
     
    @@ -937,8 +946,8 @@
              if printcom then 
             WriteLn('LockServer: ', fLock);
     {$endif}
    -        RunError(217);
    -        Result:=0;
    +          Result := CoLockObjectExternal(Self, fLock, True);
    +          ComServer.CountObject(fLock);
           end;
     
     
    @@ -1003,13 +1012,14 @@
             FComClass := ComClass;
             FInstancing := Instancing;;
             ComClassManager.AddObjectFactory(Self);
    +        fIsRegistered := dword(-1);
           end;
     
     
         destructor TComObjectFactory.Destroy;
           begin
    +        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
             ComClassManager.RemoveObjectFactory(Self);
    -        //RunError(217);
           end;
     
     
    @@ -1023,15 +1033,27 @@
             Result := TComClass(FComClass).Create();
           end;
     
    +    function TComObjectFactory.reg_flags():integer;inline;
    +    begin
    +       Result:=0;
    +       case Self.FInstancing of
    +       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
    +       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
    +       end;
    +       if FComServer.StartSuspended then
    +         Result:=Result or REGCLS_SUSPENDED;
    +    end;
     
         procedure TComObjectFactory.RegisterClassObject;
    -      begin
    +    begin
           {$ifdef DEBUG_COM}
              if printcom then 
             WriteLn('TComObjectFactory.RegisterClassObject');
           {$endif}
    -        RunError(217);
    -      end;
    +      if FInstancing <> ciInternal then
    +      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
    +         reg_flags(), @FIsRegistered));
    +    end;
     
     
     (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx)
    @@ -1066,6 +1088,7 @@
         procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
           var
             classidguid: String;
    +        srv_type: string;
     
             function ThreadModelToString(model: TThreadingModel): String;
             begin
    @@ -1086,12 +1109,14 @@
     {$endif}
             if Instancing = ciInternal then Exit;
     
    +        if System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
    +
             if Register then
             begin
               classidguid := GUIDToString(ClassID);
    -          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
    +          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
               //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
    -          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
    +          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, 'ThreadingModel', ThreadModelToString(ThreadingModel));
               CreateRegKey('CLSID\' + classidguid, '', Description);
               if ClassName <> '' then
               begin
    @@ -1115,7 +1140,7 @@
             end else
             begin
               classidguid := GUIDToString(ClassID);
    -          DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
    +          DeleteRegKey('CLSID\' + classidguid + '\'+srv_type);
               DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
               if ClassName <> '' then
               begin
    @@ -1875,4 +1900,3 @@
       if Initialized then
         CoUninitialize;
     end.
    -
    Index: packages/winunits-base/src/comserv.pp
    ===================================================================
    --- packages/winunits-base/src/comserv.pp	(revision 42475)
    +++ packages/winunits-base/src/comserv.pp	(working copy)
    @@ -37,10 +37,13 @@
       SELFREG_E_CLASS = -2;
     
     type
    +  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
    +  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
     
       { TComServer }
     
       TComServer = class(TComServerObject)
    +  class var orgInitProc: codepointer;
       private
         fCountObject: Integer;
         fCountFactory: Integer;
    @@ -48,7 +51,23 @@
         fServerName,
         fServerFileName: String;
         fHelpFileName : String;
    +    fRegister: Boolean;
         fStartSuspended : Boolean;
    +    FIsInproc: Boolean;
    +    FIsInteractive: Boolean;
    +    FStartMode: TStartMode;
    +    FOnLastRelease: TLastReleaseEvent;
    +
    +    class function AutomationDone: Boolean;
    +    class procedure AutomationStart;
    +    procedure CheckCmdLine;
    +    procedure FactoryFree(Factory: TComObjectFactory);
    +    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
    +    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
    +    procedure CheckReleased;
    +    function GetTypeLibName: widestring;
    +    procedure RegisterObjectWith(Factory: TComObjectFactory);
    +    procedure Start;
       protected
         function CountObject(Created: Boolean): Integer; override;
         function CountFactory(Created: Boolean): Integer; override;
    @@ -69,11 +88,17 @@
         function CanUnloadNow: Boolean;
         procedure RegisterServer;
         procedure UnRegisterServer;
    +    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
    +    property IsInteractive: Boolean read fIsInteractive;
    +    property StartMode: TStartMode read FStartMode;
    +    property ServerObjects:integer read fCountObject;
       end;
     
     var
       ComServer: TComServer = nil;
    +  haut :TLibHandle;
     
    +
     //http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
     //If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
     function DllCanUnloadNow: HResult; stdcall;
    @@ -219,9 +244,24 @@
     function TComServer.CountObject(Created: Boolean): Integer;
     begin
       if Created then
    -    Result:=InterLockedIncrement(fCountObject)
    +  begin
    +    Result := InterlockedIncrement(FCountObject);
    +    if (not IsInProcServer) and (StartMode = smAutomation)
    +      and Assigned(ComObj.CoAddRefServerProcess) then
    +      ComObj.CoAddRefServerProcess;
    +  end
       else
    -    Result:=InterLockedDecrement(fCountObject);
    +  begin
    +    Result := InterlockedDecrement(FCountObject);
    +    if (not IsInProcServer) and (StartMode = smAutomation)
    +      and Assigned(ComObj.CoReleaseServerProcess) then
    +    begin
    +      if ComObj.CoReleaseServerProcess() = 0 then
    +        CheckReleased;
    +    end
    +    else if Result = 0 then
    +      CheckReleased;
    +  end;
     end;
     
     function TComServer.CountFactory(Created: Boolean): Integer;
    @@ -232,6 +272,22 @@
         Result:=InterLockedDecrement(fCountFactory);
     end;
     
    +procedure TComServer.FactoryFree(Factory: TComObjectFactory);
    +begin
    +  Factory.Free;
    +end;
    +
    +procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
    +begin
    +  Factory.RegisterClassObject;
    +end;
    +
    +procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
    +begin
    +  if Factory.Instancing <> ciInternal then
    +    Factory.UpdateRegistry(FRegister);
    +end;
    +
     function TComServer.GetHelpFileName: string;
     begin
       result:=fhelpfilename;
    @@ -244,14 +300,29 @@
     
     function TComServer.GetServerKey: string;
     begin
    -  result:='LocalServer32';
    +  if FIsInproc then
    +    Result := 'InprocServer32'
    +  else
    +    Result := 'LocalServer32';
     end;
     
     function TComServer.GetServerName: string;
     begin
    -  Result := fServerName;
    +  if FServerName <> '' then
    +    Result := FServerName
    +  else
    +    if FTypeLib <> nil then
    +      Result := GetTypeLibName
    +    else
    +      Result := GetModuleName;
     end;
     
    +function TComServer.GetTypeLibName: widestring;
    +begin
    +  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
    +end;
    +
    +
     function TComServer.GetStartSuspended: Boolean;
     begin
       result:=fStartSuspended;
    @@ -262,6 +333,30 @@
       Result := fTypeLib;
     end;
     
    +procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
    +begin
    +  Factory.RegisterClassObject;
    +end;
    +
    +
    +procedure TComServer.Start;
    +begin
    +  case fStartMode of
    +  smRegServer:
    +    begin
    +      Self.RegisterServer;
    +      Halt;
    +    end;
    +  smUnregServer:
    +    begin
    +      Self.UnRegisterServer;
    +      Halt;
    +    end;
    +  end;
    +  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
    +end;
    +
    +
     procedure TComServer.SetHelpFileName(const Value: string);
     begin
       FHelpFileName:=value;
    @@ -277,10 +372,25 @@
       Factory.UpdateRegistry(False);
     end;
     
    +procedure TComServer.CheckCmdLine;
    +const
    +  sw_set:TSysCharSet = ['/','-'];
    +begin
    +  if FindCmdLineSwitch('automation',sw_set,true) or
    +     FindCmdLineSwitch('embedding',sw_set,true) then
    +    fStartMode := smAutomation
    +  else if FindCmdlIneSwitch('regserver',sw_set,true) then
    +    fStartMode := smRegServer
    +  else if FindCmdLineSwitch('unregserver',sw_set,true) then
    +    fStartMode := smUnregServer;
    +end;
    +
     constructor TComServer.Create;
     var
       name: WideString;
     begin
    +  haut := SafeLoadLibrary('oleaut32.DLL');
    +  CheckCmdLine;
       inherited Create;
     {$ifdef DEBUG_COM}
       WriteLn('TComServer.Create');
    @@ -288,6 +398,9 @@
       fCountFactory := 0;
       fCountObject := 0;
     
    +  FTypeLib := nil;
    +  FIsInproc := ModuleIsLib;
    +
       fServerFileName := GetModuleFileName();
     
       name := fServerFileName;
    @@ -301,11 +414,61 @@
       end
       else
         fServerName := GetModuleName;
    +
    +  if not ModuleIsLib then
    +  begin
    +    orgInitProc := InitProc;
    +    InitProc := @TComServer.AutomationStart;
    +  //  AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
    +  end;
    +
    +  Self.FIsInteractive := True;
     end;
     
    +class procedure TComServer.AutomationStart;
    +begin
    +  if orgInitProc <> nil then TProcedure(orgInitProc)();
    +  ComServer.FStartSuspended := (CoInitFlags <> -1) and
    +    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
    +  ComServer.Start;
    +  if ComServer.FStartSuspended then
    +    ComObj.CoResumeClassObjects;
    +end;
    +
    +class function TComServer.AutomationDone: Boolean;
    +begin
    +  Result := True;
    +  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
    +  begin
    +    Result := MessageBox(0, PChar('COM server is in use'),
    +      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
    +      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
    +  end;
    +end;
    +
    +
    +procedure TComServer.CheckReleased;
    +var
    +  Shutdown: Boolean;
    +begin
    +  if not FIsInproc then
    +  begin
    +    Shutdown := FStartMode = smAutomation;
    +    try
    +      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
    +    finally
    +      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
    +    end;
    +  end;
    +end;
    +
    +
     destructor TComServer.Destroy;
     begin
    +  ComClassManager.ForEachFactory(Self, @FactoryFree,true);
    +  Self.fTypeLib:=nil;
       inherited Destroy;
    +  FreeLibrary(haut);
     {$ifdef DEBUG_COM}
       WriteLn('TComServer.Destroy');
     {$endif}
    @@ -332,15 +495,17 @@
       ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
     end;
     
    +
     initialization
     {$ifdef DEBUG_COM}
       WriteLn('comserv initialization begin');
     {$endif}
       ComServer := TComServer.Create;
    +
     {$ifdef DEBUG_COM}
       WriteLn('comserv initialization end');
     {$endif}
     finalization
    -  ComServer.Free;
    +  ComServer.AutomationDone;
    +  FreeAndNil(ComServer);
     end.
    -
    
    35013.patch (12,969 bytes)
  • com_test.zip (4,736 bytes)

Activities

Anton Kavalenka

2019-02-05 16:21

reporter  

oleaut.zip (3,371 bytes)

Anton Kavalenka

2019-02-07 17:26

reporter  

comobj.diff (4,193 bytes)
--- C:/projects/fpc/packages/winunits-base/src/comobj.pp	�� ��� 24 01:06:36 2018
+++ P:/fpctest/oleaut/comobj.pp	�� ��  7 15:16:48 2019
@@ -25,7 +25,7 @@ unit ComObj;
   {$define DUMMY_REG}
 {$endif}
     uses
-      Windows,Types,Variants,Sysutils,ActiveX,classes;
+      Windows,Types,Variants,Sysutils,ActiveX,classes,hconst;
 
     type
       EOleError = class(Exception);
@@ -159,11 +159,12 @@ unit ComObj;
         FErrorIID: TGUID;
         FInstancing: TClassInstancing;
         FLicString: WideString;
-        //FRegister: Longint;
+        FIsRegistered: dword;
         FShowErrors: Boolean;
         FSupportsLicensing: Boolean;
         FThreadingModel: TThreadingModel;
         function GetProgID: string;
+        function reg_flags(): integer;
       protected
         { IUnknown }
         function QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall;
@@ -937,8 +938,8 @@ implementation
          if printcom then 
         WriteLn('LockServer: ', fLock);
 {$endif}
-        RunError(217);
-        Result:=0;
+          Result := CoLockObjectExternal(Self, fLock, True);
+          ComServer.CountObject(fLock);
       end;
 
 
@@ -1003,13 +1004,14 @@ implementation
         FComClass := ComClass;
         FInstancing := Instancing;;
         ComClassManager.AddObjectFactory(Self);
+        fIsRegistered := dword(-1);
       end;
 
 
     destructor TComObjectFactory.Destroy;
       begin
+        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
         ComClassManager.RemoveObjectFactory(Self);
-        //RunError(217);
       end;
 
 
@@ -1023,15 +1025,27 @@ implementation
         Result := TComClass(FComClass).Create();
       end;
 
+    function TComObjectFactory.reg_flags():integer;inline;
+    begin
+       Result:=0;
+       case Self.FInstancing of
+       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
+       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
+       end;
+       if FComServer.StartSuspended then
+         Result:=Result or REGCLS_SUSPENDED;
+    end;
 
     procedure TComObjectFactory.RegisterClassObject;
-      begin
+    begin
       {$ifdef DEBUG_COM}
          if printcom then 
         WriteLn('TComObjectFactory.RegisterClassObject');
       {$endif}
-        RunError(217);
-      end;
+      if FInstancing <> ciInternal then
+      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
+         reg_flags(), @FIsRegistered));
+    end;
 
 
 (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx)
@@ -1066,6 +1080,7 @@ HKCR
     procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
       var
         classidguid: String;
+        srv_type: string;
 
         function ThreadModelToString(model: TThreadingModel): String;
         begin
@@ -1086,12 +1101,14 @@ HKCR
 {$endif}
         if Instancing = ciInternal then Exit;
 
+        if System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
+
         if Register then
         begin
           classidguid := GUIDToString(ClassID);
-          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
+          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
           //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
-          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
+          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, 'ThreadingModel', ThreadModelToString(ThreadingModel));
           CreateRegKey('CLSID\' + classidguid, '', Description);
           if ClassName <> '' then
           begin
@@ -1115,7 +1132,7 @@ HKCR
         end else
         begin
           classidguid := GUIDToString(ClassID);
-          DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
+          DeleteRegKey('CLSID\' + classidguid + '\'+srv_type);
           DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
           if ClassName <> '' then
           begin
comobj.diff (4,193 bytes)

Anton Kavalenka

2019-02-07 17:26

reporter  

comserv.diff (7,759 bytes)
--- C:/projects/fpc/packages/winunits-base/src/comserv.pp	�� ��� 24 01:06:36 2018
+++ P:/fpctest/oleaut/comserv.pp	�� ��  7 19:18:16 2019
@@ -37,10 +37,13 @@ const
   SELFREG_E_CLASS = -2;
 
 type
+  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
+  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
 
   { TComServer }
 
   TComServer = class(TComServerObject)
+  class var orgInitProc: codepointer;
   private
     fCountObject: Integer;
     fCountFactory: Integer;
@@ -48,7 +51,23 @@ type
     fServerName,
     fServerFileName: String;
     fHelpFileName : String;
+    fRegister: Boolean;
     fStartSuspended : Boolean;
+    FIsInproc: Boolean;
+    FIsInteractive: Boolean;
+    FStartMode: TStartMode;
+    FOnLastRelease: TLastReleaseEvent;
+
+    class function AutomationDone: Boolean;
+    class procedure AutomationStart;
+    procedure CheckCmdLine;
+    procedure FactoryFree(Factory: TComObjectFactory);
+    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
+    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
+    procedure CheckReleased;
+    function GetTypeLibName: widestring;
+    procedure RegisterObjectWith(Factory: TComObjectFactory);
+    procedure Start;
   protected
     function CountObject(Created: Boolean): Integer; override;
     function CountFactory(Created: Boolean): Integer; override;
@@ -69,11 +88,17 @@ type
     function CanUnloadNow: Boolean;
     procedure RegisterServer;
     procedure UnRegisterServer;
+    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
+    property IsInteractive: Boolean read fIsInteractive;
+    property StartMode: TStartMode read FStartMode;
+    property ServerObjects:integer read fCountObject;
   end;
 
 var
   ComServer: TComServer = nil;
+  haut :TLibHandle;
 
+
 //http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
 //If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
 function DllCanUnloadNow: HResult; stdcall;
@@ -219,9 +244,24 @@ end;
 function TComServer.CountObject(Created: Boolean): Integer;
 begin
   if Created then
-    Result:=InterLockedIncrement(fCountObject)
+  begin
+    Result := InterlockedIncrement(FCountObject);
+    if (not IsInProcServer) and (StartMode = smAutomation)
+      and Assigned(ComObj.CoAddRefServerProcess) then
+      ComObj.CoAddRefServerProcess;
+  end
   else
-    Result:=InterLockedDecrement(fCountObject);
+  begin
+    Result := InterlockedDecrement(FCountObject);
+    if (not IsInProcServer) and (StartMode = smAutomation)
+      and Assigned(ComObj.CoReleaseServerProcess) then
+    begin
+      if ComObj.CoReleaseServerProcess() = 0 then
+        CheckReleased;
+    end
+    else if Result = 0 then
+      CheckReleased;
+  end;
 end;
 
 function TComServer.CountFactory(Created: Boolean): Integer;
@@ -232,6 +272,22 @@ begin
     Result:=InterLockedDecrement(fCountFactory);
 end;
 
+procedure TComServer.FactoryFree(Factory: TComObjectFactory);
+begin
+  Factory.Free;
+end;
+
+procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
+begin
+  Factory.RegisterClassObject;
+end;
+
+procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
+begin
+  if Factory.Instancing <> ciInternal then
+    Factory.UpdateRegistry(FRegister);
+end;
+
 function TComServer.GetHelpFileName: string;
 begin
   result:=fhelpfilename;
@@ -244,14 +300,29 @@ end;
 
 function TComServer.GetServerKey: string;
 begin
-  result:='LocalServer32';
+  if FIsInproc then
+    Result := 'InprocServer32'
+  else
+    Result := 'LocalServer32';
 end;
 
 function TComServer.GetServerName: string;
 begin
-  Result := fServerName;
+  if FServerName <> '' then
+    Result := FServerName
+  else
+    if FTypeLib <> nil then
+      Result := GetTypeLibName
+    else
+      Result := GetModuleName;
 end;
 
+function TComServer.GetTypeLibName: widestring;
+begin
+  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
+end;
+
+
 function TComServer.GetStartSuspended: Boolean;
 begin
   result:=fStartSuspended;
@@ -262,6 +333,30 @@ begin
   Result := fTypeLib;
 end;
 
+procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
+begin
+  Factory.RegisterClassObject;
+end;
+
+
+procedure TComServer.Start;
+begin
+  case fStartMode of
+  smRegServer:
+    begin
+      Self.RegisterServer;
+      Halt;
+    end;
+  smUnregServer:
+    begin
+      Self.UnRegisterServer;
+      Halt;
+    end;
+  end;
+  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
+end;
+
+
 procedure TComServer.SetHelpFileName(const Value: string);
 begin
   FHelpFileName:=value;
@@ -277,10 +372,25 @@ begin
   Factory.UpdateRegistry(False);
 end;
 
+procedure TComServer.CheckCmdLine;
+const
+  sw_set:TSysCharSet = ['/','-'];
+begin
+  if FindCmdLineSwitch('automation',sw_set,true) or
+     FindCmdLineSwitch('embedding',sw_set,true) then
+    fStartMode := smAutomation
+  else if FindCmdlIneSwitch('regserver',sw_set,true) then
+    fStartMode := smRegServer
+  else if FindCmdLineSwitch('unregserver',sw_set,true) then
+    fStartMode := smUnregServer;
+end;
+
 constructor TComServer.Create;
 var
   name: WideString;
 begin
+  haut := SafeLoadLibrary('oleaut32.DLL');
+  CheckCmdLine;
   inherited Create;
 {$ifdef DEBUG_COM}
   WriteLn('TComServer.Create');
@@ -288,6 +398,9 @@ begin
   fCountFactory := 0;
   fCountObject := 0;
 
+  FTypeLib := nil;
+  FIsInproc := ModuleIsLib;
+
   fServerFileName := GetModuleFileName();
 
   name := fServerFileName;
@@ -301,11 +414,60 @@ begin
   end
   else
     fServerName := GetModuleName;
+
+  if not ModuleIsLib then
+  begin
+    orgInitProc := InitProc;
+    InitProc := @TComServer.AutomationStart;
+    AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
+  end;
+
+  Self.FIsInteractive := True;
 end;
 
+class procedure TComServer.AutomationStart;
+begin
+  if orgInitProc <> nil then TProcedure(orgInitProc)();
+  ComServer.FStartSuspended := (CoInitFlags <> -1) and
+    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
+  ComServer.Start;
+  if ComServer.FStartSuspended then
+    ComObj.CoResumeClassObjects;
+end;
+
+class function TComServer.AutomationDone: Boolean;
+begin
+  Result := True;
+  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
+  begin
+    Result := MessageBox(0, PChar('COM server is in use'),
+      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
+      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
+  end;
+end;
+
+
+procedure TComServer.CheckReleased;
+var
+  Shutdown: Boolean;
+begin
+  if not FIsInproc then
+  begin
+    Shutdown := FStartMode = smAutomation;
+    try
+      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
+    finally
+      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
+    end;
+  end;
+end;
+
+
 destructor TComServer.Destroy;
 begin
+  ComClassManager.ForEachFactory(Self, @FactoryFree);
   inherited Destroy;
+  FreeLibrary(haut);
 {$ifdef DEBUG_COM}
   WriteLn('TComServer.Destroy');
 {$endif}
@@ -332,15 +494,17 @@ begin
   ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
 end;
 
+
 initialization
 {$ifdef DEBUG_COM}
   WriteLn('comserv initialization begin');
 {$endif}
   ComServer := TComServer.Create;
+
 {$ifdef DEBUG_COM}
   WriteLn('comserv initialization end');
 {$endif}
 finalization
-  ComServer.Free;
+  FreeAndNil(ComServer);
 end.
 
comserv.diff (7,759 bytes)

Anton Kavalenka

2019-02-07 17:27

reporter   ~0113929

Set of patches provided

new test uploaded

Anton Kavalenka

2019-02-07 17:28

reporter  

oleaut1.zip (1,943 bytes)

Marco van de Voort

2019-02-09 14:43

manager   ~0113981

I removed hconst. It looked like Delphi code (but maybe you got it from Jedi? I couldn't tell quickly and without looking at Delphi source, so I removed it) Please don't ever work with copyrighted code when making patches for FPC.

Marco van de Voort

2019-02-09 14:43

manager   ~0113982

I did copy some of the constants from MSDN though, they are now in trunk (the first and last already were, in unit windows)

Anton Kavalenka

2019-02-09 16:42

reporter   ~0113990

Last edited: 2019-02-09 16:48

View 3 revisions

the purpose of hconst was just to place OLE-specific constants, which obviously have to be in Windows or Activex.

To be clearly different from Delphi code the GetServerName have to return fServerName as it did before the patch (it is already determined in constructor)

Anton Kavalenka

2019-07-19 15:34

reporter   ~0117316

recent updates with work around 0035862 (to prevent memory leaks)

comobj-2.diff (137,245 bytes)
--- P:/ulinuxg/comobj.pp	�� ˳� 19 16:24:56 2019
+++ P:/fpc/packages/winunits-base/src/comobj.pp	�� ��� 30 18:32:21 2018
@@ -1,1903 +1,1878 @@
-{
-    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;const bBackward:boolean=false);
-        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;
-        FIsRegistered: dword;
-        FShowErrors: Boolean;
-        FSupportsLicensing: Boolean;
-        FThreadingModel: TThreadingModel;
-        function GetProgID: string;
-        function reg_flags(): integer;
-      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;
-
-    function StringToLPOLESTR(const Source: string): POLEStr;
-
-    procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
-    procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
-
-    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;
-
-
-   function StringToLPOLESTR(const Source: string): POLEStr;
-     var
-       Src: WideString;
-     begin
-       Src := WideString(Source);
-       Result := CoTaskMemAlloc((Length(Src)+1) * SizeOf(WideChar));
-       if Result <> nil then
-         Move(PWideChar(Src)^, Result^, (Length(Src)+1) * SizeOf(WideChar));
-     end;
-
-
-   procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
-     var
-       CPC: IConnectionPointContainer;
-       CP: IConnectionPoint;
-       i: hresult;
-     begin
-       Connection := 0;
-       if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
-         if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
-           i:=CP.Advise(Sink, Connection);
-     end;
-
-
-   procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
-     var
-       CPC: IConnectionPointContainer;
-       CP: IConnectionPoint;
-       i: hresult;
-     begin
-       if Connection <> 0 then
-         if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
-           if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
-           begin
-             i:=CP.Unadvise(Connection);
-             if Succeeded(i) then Connection := 0;
-           end;
-     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;const bBackward:boolean=false);
-      var
-        i: Integer;
-        obj: TComObjectFactory;
-      begin
-{$ifdef DEBUG_COM}
-         if printcom then 
-        WriteLn('ForEachFactory');
-{$endif}
-        if not bBackward then
-        for i := 0 to fClassFactoryList.Count - 1 do
-        begin
-          obj := TComObjectFactory(fClassFactoryList[i]);
-          if obj.ComServer = ComServer then
-            FactoryProc(obj);
-        end
-        else
-        for i := fClassFactoryList.Count - 1 downto 0 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}
-          Result := CoLockObjectExternal(Self, fLock, True);
-          ComServer.CountObject(fLock);
-      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);
-        fIsRegistered := dword(-1);
-      end;
-
-
-    destructor TComObjectFactory.Destroy;
-      begin
-        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
-        ComClassManager.RemoveObjectFactory(Self);
-      end;
-
-
-    function TComObjectFactory.CreateComObject(const Controller: IUnknown
-      ): TComObject;
-      begin
-{$ifdef DEBUG_COM}
-         if printcom then 
-        WriteLn('TComObjectFactory.CreateComObject');
-{$endif}
-        Result := TComClass(FComClass).Create();
-      end;
-
-    function TComObjectFactory.reg_flags():integer;inline;
-    begin
-       Result:=0;
-       case Self.FInstancing of
-       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
-       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
-       end;
-       if FComServer.StartSuspended then
-         Result:=Result or REGCLS_SUSPENDED;
-    end;
-
-    procedure TComObjectFactory.RegisterClassObject;
-    begin
-      {$ifdef DEBUG_COM}
-         if printcom then 
-        WriteLn('TComObjectFactory.RegisterClassObject');
-      {$endif}
-      if FInstancing <> ciInternal then
-      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
-         reg_flags(), @FIsRegistered));
-    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;
-        srv_type: 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 System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
-
-        if Register then
-        begin
-          classidguid := GUIDToString(ClassID);
-          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
-          //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
-          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '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 + '\'+srv_type);
-          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:
-              { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
-                flags for anything returning a result, see bug #24352 }
-              if assigned(Result) 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:
-            { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
-              flags for anything returning a result, see bug #24352 }
-            if assigned(res) 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.
-
+{
+    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;
+
+    function StringToLPOLESTR(const Source: string): POLEStr;
+
+    procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
+    procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
+
+    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;
+
+
+   function StringToLPOLESTR(const Source: string): POLEStr;
+     var
+       Src: WideString;
+     begin
+       Src := WideString(Source);
+       Result := CoTaskMemAlloc((Length(Src)+1) * SizeOf(WideChar));
+       if Result <> nil then
+         Move(PWideChar(Src)^, Result^, (Length(Src)+1) * SizeOf(WideChar));
+     end;
+
+
+   procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: DWORD);
+     var
+       CPC: IConnectionPointContainer;
+       CP: IConnectionPoint;
+       i: hresult;
+     begin
+       Connection := 0;
+       if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
+         if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
+           i:=CP.Advise(Sink, Connection);
+     end;
+
+
+   procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: DWORD);
+     var
+       CPC: IConnectionPointContainer;
+       CP: IConnectionPoint;
+       i: hresult;
+     begin
+       if Connection <> 0 then
+         if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
+           if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
+           begin
+             i:=CP.Unadvise(Connection);
+             if Succeeded(i) then Connection := 0;
+           end;
+     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:
+              { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
+                flags for anything returning a result, see bug #24352 }
+              if assigned(Result) 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:
+            { It appears that certain COM servers expect both DISPATCH_METHOD and DISPATCH_PROPERTYGET
+              flags for anything returning a result, see bug #24352 }
+            if assigned(res) 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.
+
comobj-2.diff (137,245 bytes)
comserv-2.diff (22,872 bytes)
--- P:/ulinuxg/comserv.pp	�� ˳� 19 16:32:01 2019
+++ P:/fpc/packages/winunits-base/src/comserv.pp	�� ��� 30 18:32:21 2018
@@ -1,512 +1,346 @@
-{
-    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 ComServ;
-
-interface
-
-uses
-  Classes, SysUtils, comobj, ActiveX;
-
-{ $define DEBUG_COM}
-
-//according to doc
-// * ComServer Variable
-// * DllCanUnloadNow Routine
-// * DllGetClassObject Routine
-// * DllRegisterServer Routine
-// * DllUnregisterServer Routine
-// * TComServer Class
-
-//TODO Fix this
-const
-  CLASS_E_CLASSNOTAVAILABLE = -1;
-  SELFREG_E_CLASS = -2;
-
-type
-  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
-  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
-
-  { TComServer }
-
-  TComServer = class(TComServerObject)
-  class var orgInitProc: codepointer;
-  private
-    fCountObject: Integer;
-    fCountFactory: Integer;
-    fTypeLib: ITypeLib;
-    fServerName,
-    fServerFileName: String;
-    fHelpFileName : String;
-    fRegister: Boolean;
-    fStartSuspended : Boolean;
-    FIsInproc: Boolean;
-    FIsInteractive: Boolean;
-    FStartMode: TStartMode;
-    FOnLastRelease: TLastReleaseEvent;
-
-    class function AutomationDone: Boolean;
-    class procedure AutomationStart;
-    procedure CheckCmdLine;
-    procedure FactoryFree(Factory: TComObjectFactory);
-    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
-    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
-    procedure CheckReleased;
-    function GetTypeLibName: widestring;
-    procedure RegisterObjectWith(Factory: TComObjectFactory);
-    procedure Start;
-  protected
-    function CountObject(Created: Boolean): Integer; override;
-    function CountFactory(Created: Boolean): Integer; override;
-    function GetHelpFileName: string; override;
-    function GetServerFileName: string; override;
-    function GetServerKey: string; override;
-    function GetServerName: string; override;
-    function GetStartSuspended: Boolean; override;
-    function GetTypeLib: ITypeLib; override;
-    procedure SetHelpFileName(const Value: string); override;
-
-
-    procedure RegisterServerFactory(Factory: TComObjectFactory);
-    procedure UnregisterServerFactory(Factory: TComObjectFactory);
-  public
-    constructor Create;
-    destructor Destroy; override;
-    function CanUnloadNow: Boolean;
-    procedure RegisterServer;
-    procedure UnRegisterServer;
-    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
-    property IsInteractive: Boolean read fIsInteractive;
-    property StartMode: TStartMode read FStartMode;
-    property ServerObjects:integer read fCountObject;
-  end;
-
-var
-  ComServer: TComServer = nil;
-  haut :TLibHandle;
-
-
-//http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
-//If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
-function DllCanUnloadNow: HResult; stdcall;
-
-
-//S_OK - The object was retrieved successfully.
-//CLASS_E_CLASSNOTAVAILABLE - The DLL does not support the class (object definition).
-function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
-
-//S_OK - The registry entries were created successfully.
-//SELFREG_E_TYPELIB - The server was unable to complete the registration of all the type libraries used by its classes.
-//SELFREG_E_CLASS - The server was unable to complete the registration of all the object classes.
-function DllRegisterServer: HResult; stdcall;
-
-//S_OK - The registry entries were deleted successfully.
-//S_FALSE - Unregistration of this server's known entries was successful, but other entries still exist for this server's classes.
-//SELFREG_E_TYPELIB - The server was unable to remove the entries of all the type libraries used by its classes.
-//SELFREG_E_CLASS - The server was unable to remove the entries of all the object classes.
-function DllUnregisterServer: HResult; stdcall;
-
-implementation
-
-uses
-  Windows;
-
-function DllCanUnloadNow: HResult; stdcall;
-begin
-{$ifdef DEBUG_COM}
-  WriteLn('DllCanUnloadNow called');
-{$endif}
-  if ComServer.CanUnloadNow then
-    Result := S_OK
-  else
-    Result := S_FALSE;
-{$ifdef DEBUG_COM}
-    WriteLn('DllCanUnloadNow return: ', Result);
-{$endif}
-end;
-
-(*
-    //FROM MSDN (Error messages are different in MSDN.DllGetClassObject)
-
-    HRESULT hres = E_OUTOFMEMORY;
-    *ppvObj = NULL;
-
-    CClassFactory *pClassFactory = new CClassFactory(rclsid);
-    if (pClassFactory != NULL)   {
-        hRes = pClassFactory->QueryInterface(riid, ppvObj);
-        pClassFactory->Release();
-    }
-    return hRes;
-*)
-
-function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
-var
-  factory: TComObjectFactory;
-begin
-{$ifdef DEBUG_COM}
-  WriteLn('DllGetClassObject called: ', GUIDToString(rclsid), ' ', GUIDToString(riid));
-{$endif}
-
-  factory := ComClassManager.GetFactoryFromClassID(rclsid);
-  if factory = nil then
-    Result := CLASS_E_CLASSNOTAVAILABLE
-  else
-  begin
-    if factory.GetInterface(riid,ppv) then
-      Result := S_OK
-    else
-      Result := CLASS_E_CLASSNOTAVAILABLE;
-{$ifdef DEBUG_COM}
-    WriteLn('DllGetClassObject return: ', Result);
-{$endif}
-  end;
-end;
-
-function DllRegisterServer: HResult; stdcall;
-begin
-{$ifdef DEBUG_COM}
-  WriteLn('DllRegisterServer called');
-{$endif}
-  try
-    ComServer.RegisterServer;
-    Result := S_OK;
-  except
-    Result := SELFREG_E_CLASS;
-  end;
-
-end;
-
-function DllUnregisterServer: HResult; stdcall;
-begin
-{$ifdef DEBUG_COM}
-  WriteLn('DllUnregisterServer called');
-{$endif}
-  try
-    ComServer.UnregisterServer;
-    Result := S_OK;
-  except
-    Result := SELFREG_E_CLASS;
-  end;
-end;
-
-function GetModuleFileName: String;
-const
-  MAX_PATH_SIZE = 2048;
-begin
-  SetLength(Result, MAX_PATH_SIZE);
-  SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
-end;
-
-function GetModuleName: String;
-begin
-  Result := ExtractFileName(GetModuleFileName);
-  Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
-end;
-
-procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
-var
-  FullPath: WideString;
-begin
-  FullPath := ModuleName;
-  //according to MSDN helpdir can be null
-  OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
-end;
-
-procedure UnRegisterTypeLib(TypeLib: ITypeLib);
-var
-  ptla: PTLibAttr;
-begin
-  //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
-  OleCheck(TypeLib.GetLibAttr(ptla));
-  try
-    ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind);
-  finally
-    TypeLib.ReleaseTLibAttr(ptla);
-  end;
-end;
-
-
-{ TComServer }
-
-function TComServer.CountObject(Created: Boolean): Integer;
-begin
-  if Created then
-  begin
-    Result := InterlockedIncrement(FCountObject);
-    if (not IsInProcServer) and (StartMode = smAutomation)
-      and Assigned(ComObj.CoAddRefServerProcess) then
-      ComObj.CoAddRefServerProcess;
-  end
-  else
-  begin
-    Result := InterlockedDecrement(FCountObject);
-    if (not IsInProcServer) and (StartMode = smAutomation)
-      and Assigned(ComObj.CoReleaseServerProcess) then
-    begin
-      if ComObj.CoReleaseServerProcess() = 0 then
-        CheckReleased;
-    end
-    else if Result = 0 then
-      CheckReleased;
-  end;
-end;
-
-function TComServer.CountFactory(Created: Boolean): Integer;
-begin
-  if Created then
-    Result:=InterLockedIncrement(fCountFactory)
-  else
-    Result:=InterLockedDecrement(fCountFactory);
-end;
-
-procedure TComServer.FactoryFree(Factory: TComObjectFactory);
-begin
-  Factory.Free;
-end;
-
-procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
-begin
-  Factory.RegisterClassObject;
-end;
-
-procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
-begin
-  if Factory.Instancing <> ciInternal then
-    Factory.UpdateRegistry(FRegister);
-end;
-
-function TComServer.GetHelpFileName: string;
-begin
-  result:=fhelpfilename;
-end;
-
-function TComServer.GetServerFileName: string;
-begin
-  Result := fServerFileName;
-end;
-
-function TComServer.GetServerKey: string;
-begin
-  if FIsInproc then
-    Result := 'InprocServer32'
-  else
-    Result := 'LocalServer32';
-end;
-
-function TComServer.GetServerName: string;
-begin
-  if FServerName <> '' then
-    Result := FServerName
-  else
-    if FTypeLib <> nil then
-      Result := GetTypeLibName
-    else
-      Result := GetModuleName;
-end;
-
-function TComServer.GetTypeLibName: widestring;
-begin
-  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
-end;
-
-
-function TComServer.GetStartSuspended: Boolean;
-begin
-  result:=fStartSuspended;
-end;
-
-function TComServer.GetTypeLib: ITypeLib;
-begin
-  Result := fTypeLib;
-end;
-
-procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
-begin
-  Factory.RegisterClassObject;
-end;
-
-
-procedure TComServer.Start;
-begin
-  case fStartMode of
-  smRegServer:
-    begin
-      Self.RegisterServer;
-      Halt;
-    end;
-  smUnregServer:
-    begin
-      Self.UnRegisterServer;
-      Halt;
-    end;
-  end;
-  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
-end;
-
-
-procedure TComServer.SetHelpFileName(const Value: string);
-begin
-  FHelpFileName:=value;
-end;
-
-procedure TComServer.RegisterServerFactory(Factory: TComObjectFactory);
-begin
-  Factory.UpdateRegistry(True);
-end;
-
-procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
-begin
-  Factory.UpdateRegistry(False);
-end;
-
-procedure TComServer.CheckCmdLine;
-const
-  sw_set:TSysCharSet = ['/','-'];
-begin
-  if FindCmdLineSwitch('automation',sw_set,true) or
-     FindCmdLineSwitch('embedding',sw_set,true) then
-    fStartMode := smAutomation
-  else if FindCmdlIneSwitch('regserver',sw_set,true) then
-    fStartMode := smRegServer
-  else if FindCmdLineSwitch('unregserver',sw_set,true) then
-    fStartMode := smUnregServer;
-end;
-
-constructor TComServer.Create;
-var
-  name: WideString;
-begin
-  haut := SafeLoadLibrary('oleaut32.DLL');
-  CheckCmdLine;
-  inherited Create;
-{$ifdef DEBUG_COM}
-  WriteLn('TComServer.Create');
-{$endif}
-  fCountFactory := 0;
-  fCountObject := 0;
-
-  FTypeLib := nil;
-  FIsInproc := ModuleIsLib;
-
-  fServerFileName := GetModuleFileName();
-
-  name := fServerFileName;
-  if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
-    fTypeLib := nil;
-
-  if FTypeLib <> nil then
-  begin
-    fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
-    fServerName := name;
-  end
-  else
-    fServerName := GetModuleName;
-
-  if not ModuleIsLib then
-  begin
-    orgInitProc := InitProc;
-    InitProc := @TComServer.AutomationStart;
-  //  AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
-  end;
-
-  Self.FIsInteractive := True;
-end;
-
-class procedure TComServer.AutomationStart;
-begin
-  if orgInitProc <> nil then TProcedure(orgInitProc)();
-  ComServer.FStartSuspended := (CoInitFlags <> -1) and
-    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
-  ComServer.Start;
-  if ComServer.FStartSuspended then
-    ComObj.CoResumeClassObjects;
-end;
-
-class function TComServer.AutomationDone: Boolean;
-begin
-  Result := True;
-  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
-  begin
-    Result := MessageBox(0, PChar('COM server is in use'),
-      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
-      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
-  end;
-end;
-
-
-procedure TComServer.CheckReleased;
-var
-  Shutdown: Boolean;
-begin
-  if not FIsInproc then
-  begin
-    Shutdown := FStartMode = smAutomation;
-    try
-      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
-    finally
-      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
-    end;
-  end;
-end;
-
-
-destructor TComServer.Destroy;
-begin
-  ComClassManager.ForEachFactory(Self, @FactoryFree,true);
-  Self.fTypeLib:=nil;
-  inherited Destroy;
-  FreeLibrary(haut);
-{$ifdef DEBUG_COM}
-  WriteLn('TComServer.Destroy');
-{$endif}
-end;
-
-function TComServer.CanUnloadNow: Boolean;
-begin
-  Result := False;
-end;
-
-procedure TComServer.RegisterServer;
-begin
-  if fTypeLib <> nil then
-    RegisterTypeLib(fTypeLib, fServerFileName);
-
-  ComClassManager.ForEachFactory(self, @RegisterServerFactory);
-end;
-
-procedure TComServer.UnRegisterServer;
-begin
-  if fTypeLib <> nil then
-    UnRegisterTypeLib(fTypeLib);
-
-  ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
-end;
-
-
-initialization
-{$ifdef DEBUG_COM}
-  WriteLn('comserv initialization begin');
-{$endif}
-  ComServer := TComServer.Create;
-
-{$ifdef DEBUG_COM}
-  WriteLn('comserv initialization end');
-{$endif}
-finalization
-  ComServer.AutomationDone;
-  FreeAndNil(ComServer);
-end.
-
+{
+    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 ComServ;
+
+interface
+
+uses
+  Classes, SysUtils, comobj, ActiveX;
+
+{ $define DEBUG_COM}
+
+//according to doc
+// * ComServer Variable
+// * DllCanUnloadNow Routine
+// * DllGetClassObject Routine
+// * DllRegisterServer Routine
+// * DllUnregisterServer Routine
+// * TComServer Class
+
+//TODO Fix this
+const
+  CLASS_E_CLASSNOTAVAILABLE = -1;
+  SELFREG_E_CLASS = -2;
+
+type
+
+  { TComServer }
+
+  TComServer = class(TComServerObject)
+  private
+    fCountObject: Integer;
+    fCountFactory: Integer;
+    fTypeLib: ITypeLib;
+    fServerName,
+    fServerFileName: String;
+    fHelpFileName : String;
+    fStartSuspended : Boolean;
+  protected
+    function CountObject(Created: Boolean): Integer; override;
+    function CountFactory(Created: Boolean): Integer; override;
+    function GetHelpFileName: string; override;
+    function GetServerFileName: string; override;
+    function GetServerKey: string; override;
+    function GetServerName: string; override;
+    function GetStartSuspended: Boolean; override;
+    function GetTypeLib: ITypeLib; override;
+    procedure SetHelpFileName(const Value: string); override;
+
+
+    procedure RegisterServerFactory(Factory: TComObjectFactory);
+    procedure UnregisterServerFactory(Factory: TComObjectFactory);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function CanUnloadNow: Boolean;
+    procedure RegisterServer;
+    procedure UnRegisterServer;
+  end;
+
+var
+  ComServer: TComServer = nil;
+
+//http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
+//If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
+function DllCanUnloadNow: HResult; stdcall;
+
+
+//S_OK - The object was retrieved successfully.
+//CLASS_E_CLASSNOTAVAILABLE - The DLL does not support the class (object definition).
+function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
+
+//S_OK - The registry entries were created successfully.
+//SELFREG_E_TYPELIB - The server was unable to complete the registration of all the type libraries used by its classes.
+//SELFREG_E_CLASS - The server was unable to complete the registration of all the object classes.
+function DllRegisterServer: HResult; stdcall;
+
+//S_OK - The registry entries were deleted successfully.
+//S_FALSE - Unregistration of this server's known entries was successful, but other entries still exist for this server's classes.
+//SELFREG_E_TYPELIB - The server was unable to remove the entries of all the type libraries used by its classes.
+//SELFREG_E_CLASS - The server was unable to remove the entries of all the object classes.
+function DllUnregisterServer: HResult; stdcall;
+
+implementation
+
+uses
+  Windows;
+
+function DllCanUnloadNow: HResult; stdcall;
+begin
+{$ifdef DEBUG_COM}
+  WriteLn('DllCanUnloadNow called');
+{$endif}
+  if ComServer.CanUnloadNow then
+    Result := S_OK
+  else
+    Result := S_FALSE;
+{$ifdef DEBUG_COM}
+    WriteLn('DllCanUnloadNow return: ', Result);
+{$endif}
+end;
+
+(*
+    //FROM MSDN (Error messages are different in MSDN.DllGetClassObject)
+
+    HRESULT hres = E_OUTOFMEMORY;
+    *ppvObj = NULL;
+
+    CClassFactory *pClassFactory = new CClassFactory(rclsid);
+    if (pClassFactory != NULL)   {
+        hRes = pClassFactory->QueryInterface(riid, ppvObj);
+        pClassFactory->Release();
+    }
+    return hRes;
+*)
+
+function DllGetClassObject(constref rclsid: REFIID {should be REFCLSID}; constref riid: REFIID; out ppv: Pointer): HResult; stdcall;
+var
+  factory: TComObjectFactory;
+begin
+{$ifdef DEBUG_COM}
+  WriteLn('DllGetClassObject called: ', GUIDToString(rclsid), ' ', GUIDToString(riid));
+{$endif}
+
+  factory := ComClassManager.GetFactoryFromClassID(rclsid);
+  if factory = nil then
+    Result := CLASS_E_CLASSNOTAVAILABLE
+  else
+  begin
+    if factory.GetInterface(riid,ppv) then
+      Result := S_OK
+    else
+      Result := CLASS_E_CLASSNOTAVAILABLE;
+{$ifdef DEBUG_COM}
+    WriteLn('DllGetClassObject return: ', Result);
+{$endif}
+  end;
+end;
+
+function DllRegisterServer: HResult; stdcall;
+begin
+{$ifdef DEBUG_COM}
+  WriteLn('DllRegisterServer called');
+{$endif}
+  try
+    ComServer.RegisterServer;
+    Result := S_OK;
+  except
+    Result := SELFREG_E_CLASS;
+  end;
+
+end;
+
+function DllUnregisterServer: HResult; stdcall;
+begin
+{$ifdef DEBUG_COM}
+  WriteLn('DllUnregisterServer called');
+{$endif}
+  try
+    ComServer.UnregisterServer;
+    Result := S_OK;
+  except
+    Result := SELFREG_E_CLASS;
+  end;
+end;
+
+function GetModuleFileName: String;
+const
+  MAX_PATH_SIZE = 2048;
+begin
+  SetLength(Result, MAX_PATH_SIZE);
+  SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
+end;
+
+function GetModuleName: String;
+begin
+  Result := ExtractFileName(GetModuleFileName);
+  Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
+end;
+
+procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
+var
+  FullPath: WideString;
+begin
+  FullPath := ModuleName;
+  //according to MSDN helpdir can be null
+  OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
+end;
+
+procedure UnRegisterTypeLib(TypeLib: ITypeLib);
+var
+  ptla: PTLibAttr;
+begin
+  //http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
+  OleCheck(TypeLib.GetLibAttr(ptla));
+  try
+    ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind);
+  finally
+    TypeLib.ReleaseTLibAttr(ptla);
+  end;
+end;
+
+
+{ TComServer }
+
+function TComServer.CountObject(Created: Boolean): Integer;
+begin
+  if Created then
+    Result:=InterLockedIncrement(fCountObject)
+  else
+    Result:=InterLockedDecrement(fCountObject);
+end;
+
+function TComServer.CountFactory(Created: Boolean): Integer;
+begin
+  if Created then
+    Result:=InterLockedIncrement(fCountFactory)
+  else
+    Result:=InterLockedDecrement(fCountFactory);
+end;
+
+function TComServer.GetHelpFileName: string;
+begin
+  result:=fhelpfilename;
+end;
+
+function TComServer.GetServerFileName: string;
+begin
+  Result := fServerFileName;
+end;
+
+function TComServer.GetServerKey: string;
+begin
+  result:='LocalServer32';
+end;
+
+function TComServer.GetServerName: string;
+begin
+  Result := fServerName;
+end;
+
+function TComServer.GetStartSuspended: Boolean;
+begin
+  result:=fStartSuspended;
+end;
+
+function TComServer.GetTypeLib: ITypeLib;
+begin
+  Result := fTypeLib;
+end;
+
+procedure TComServer.SetHelpFileName(const Value: string);
+begin
+  FHelpFileName:=value;
+end;
+
+procedure TComServer.RegisterServerFactory(Factory: TComObjectFactory);
+begin
+  Factory.UpdateRegistry(True);
+end;
+
+procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
+begin
+  Factory.UpdateRegistry(False);
+end;
+
+constructor TComServer.Create;
+var
+  name: WideString;
+begin
+  inherited Create;
+{$ifdef DEBUG_COM}
+  WriteLn('TComServer.Create');
+{$endif}
+  fCountFactory := 0;
+  fCountObject := 0;
+
+  fServerFileName := GetModuleFileName();
+
+  name := fServerFileName;
+  if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
+    fTypeLib := nil;
+
+  if FTypeLib <> nil then
+  begin
+    fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
+    fServerName := name;
+  end
+  else
+    fServerName := GetModuleName;
+end;
+
+destructor TComServer.Destroy;
+begin
+  inherited Destroy;
+{$ifdef DEBUG_COM}
+  WriteLn('TComServer.Destroy');
+{$endif}
+end;
+
+function TComServer.CanUnloadNow: Boolean;
+begin
+  Result := False;
+end;
+
+procedure TComServer.RegisterServer;
+begin
+  if fTypeLib <> nil then
+    RegisterTypeLib(fTypeLib, fServerFileName);
+
+  ComClassManager.ForEachFactory(self, @RegisterServerFactory);
+end;
+
+procedure TComServer.UnRegisterServer;
+begin
+  if fTypeLib <> nil then
+    UnRegisterTypeLib(fTypeLib);
+
+  ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
+end;
+
+initialization
+{$ifdef DEBUG_COM}
+  WriteLn('comserv initialization begin');
+{$endif}
+  ComServer := TComServer.Create;
+{$ifdef DEBUG_COM}
+  WriteLn('comserv initialization end');
+{$endif}
+finalization
+  ComServer.Free;
+end.
+
comserv-2.diff (22,872 bytes)

Sven Barth

2019-07-19 16:36

manager   ~0117318

It seems you changed the line endings with your patches. Please don't do that as it makes it basically impossible to see what changed.

Do-wan Kim

2019-07-21 08:49

reporter  

35013.patch (12,969 bytes)
Index: packages/winunits-base/src/comobj.pp
===================================================================
--- packages/winunits-base/src/comobj.pp	(revision 42475)
+++ packages/winunits-base/src/comobj.pp	(working copy)
@@ -92,7 +92,7 @@
         destructor Destroy; override;
         procedure AddObjectFactory(factory: TComObjectFactory);
         procedure RemoveObjectFactory(factory: TComObjectFactory);
-        procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc);
+        procedure ForEachFactory(ComServer: TComServerObject; FactoryProc: TFactoryProc;const bBackward:boolean=false);
         function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
         function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
       end;
@@ -159,11 +159,12 @@
         FErrorIID: TGUID;
         FInstancing: TClassInstancing;
         FLicString: WideString;
-        //FRegister: Longint;
+        FIsRegistered: dword;
         FShowErrors: Boolean;
         FSupportsLicensing: Boolean;
         FThreadingModel: TThreadingModel;
         function GetProgID: string;
+        function reg_flags(): integer;
       protected
         { IUnknown }
         function QueryInterface(constref IID: TGUID; out Obj): HResult; stdcall;
@@ -694,7 +695,7 @@
       end;
 
     procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
-      FactoryProc: TFactoryProc);
+      FactoryProc: TFactoryProc;const bBackward:boolean=false);
       var
         i: Integer;
         obj: TComObjectFactory;
@@ -703,12 +704,20 @@
          if printcom then 
         WriteLn('ForEachFactory');
 {$endif}
+        if not bBackward then
         for i := 0 to fClassFactoryList.Count - 1 do
         begin
           obj := TComObjectFactory(fClassFactoryList[i]);
           if obj.ComServer = ComServer then
             FactoryProc(obj);
-        end;
+        end
+        else
+        for i := fClassFactoryList.Count - 1 downto 0 do
+        begin
+          obj := TComObjectFactory(fClassFactoryList[i]);
+          if obj.ComServer = ComServer then
+            FactoryProc(obj);
+        end
       end;
 
 
@@ -937,8 +946,8 @@
          if printcom then 
         WriteLn('LockServer: ', fLock);
 {$endif}
-        RunError(217);
-        Result:=0;
+          Result := CoLockObjectExternal(Self, fLock, True);
+          ComServer.CountObject(fLock);
       end;
 
 
@@ -1003,13 +1012,14 @@
         FComClass := ComClass;
         FInstancing := Instancing;;
         ComClassManager.AddObjectFactory(Self);
+        fIsRegistered := dword(-1);
       end;
 
 
     destructor TComObjectFactory.Destroy;
       begin
+        if fIsRegistered <> dword(-1) then CoRevokeClassObject(fIsRegistered);
         ComClassManager.RemoveObjectFactory(Self);
-        //RunError(217);
       end;
 
 
@@ -1023,15 +1033,27 @@
         Result := TComClass(FComClass).Create();
       end;
 
+    function TComObjectFactory.reg_flags():integer;inline;
+    begin
+       Result:=0;
+       case Self.FInstancing of
+       ciSingleInstance: Result:=Result or REGCLS_SINGLEUSE;
+       ciMultiInstance: Result:=Result or REGCLS_MULTIPLEUSE;
+       end;
+       if FComServer.StartSuspended then
+         Result:=Result or REGCLS_SUSPENDED;
+    end;
 
     procedure TComObjectFactory.RegisterClassObject;
-      begin
+    begin
       {$ifdef DEBUG_COM}
          if printcom then 
         WriteLn('TComObjectFactory.RegisterClassObject');
       {$endif}
-        RunError(217);
-      end;
+      if FInstancing <> ciInternal then
+      OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
+         reg_flags(), @FIsRegistered));
+    end;
 
 
 (* Copy from Sample.RGS (http://www.codeproject.com/KB/atl/RegistryMap.aspx)
@@ -1066,6 +1088,7 @@
     procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
       var
         classidguid: String;
+        srv_type: string;
 
         function ThreadModelToString(model: TThreadingModel): String;
         begin
@@ -1086,12 +1109,14 @@
 {$endif}
         if Instancing = ciInternal then Exit;
 
+        if System.ModuleIsLib then srv_type:='InprocServer32' else srv_type:='LocalServer32';
+
         if Register then
         begin
           classidguid := GUIDToString(ClassID);
-          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
+          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, '', FComServer.ServerFileName);
           //tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
-          CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
+          CreateRegKey('CLSID\' + classidguid + '\'+srv_type, 'ThreadingModel', ThreadModelToString(ThreadingModel));
           CreateRegKey('CLSID\' + classidguid, '', Description);
           if ClassName <> '' then
           begin
@@ -1115,7 +1140,7 @@
         end else
         begin
           classidguid := GUIDToString(ClassID);
-          DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
+          DeleteRegKey('CLSID\' + classidguid + '\'+srv_type);
           DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
           if ClassName <> '' then
           begin
@@ -1875,4 +1900,3 @@
   if Initialized then
     CoUninitialize;
 end.
-
Index: packages/winunits-base/src/comserv.pp
===================================================================
--- packages/winunits-base/src/comserv.pp	(revision 42475)
+++ packages/winunits-base/src/comserv.pp	(working copy)
@@ -37,10 +37,13 @@
   SELFREG_E_CLASS = -2;
 
 type
+  TStartMode = (smStandalone, smAutomation,smRegserver,smUnregserver);
+  TLastReleaseEvent = procedure(var shutdown: Boolean) of object;
 
   { TComServer }
 
   TComServer = class(TComServerObject)
+  class var orgInitProc: codepointer;
   private
     fCountObject: Integer;
     fCountFactory: Integer;
@@ -48,7 +51,23 @@
     fServerName,
     fServerFileName: String;
     fHelpFileName : String;
+    fRegister: Boolean;
     fStartSuspended : Boolean;
+    FIsInproc: Boolean;
+    FIsInteractive: Boolean;
+    FStartMode: TStartMode;
+    FOnLastRelease: TLastReleaseEvent;
+
+    class function AutomationDone: Boolean;
+    class procedure AutomationStart;
+    procedure CheckCmdLine;
+    procedure FactoryFree(Factory: TComObjectFactory);
+    procedure FactoryRegisterClassObject(Factory: TComObjectFactory);
+    procedure FactoryUpdateRegistry(Factory: TComObjectFactory);
+    procedure CheckReleased;
+    function GetTypeLibName: widestring;
+    procedure RegisterObjectWith(Factory: TComObjectFactory);
+    procedure Start;
   protected
     function CountObject(Created: Boolean): Integer; override;
     function CountFactory(Created: Boolean): Integer; override;
@@ -69,11 +88,17 @@
     function CanUnloadNow: Boolean;
     procedure RegisterServer;
     procedure UnRegisterServer;
+    property IsInprocServer: Boolean read FIsInproc write FIsInproc;
+    property IsInteractive: Boolean read fIsInteractive;
+    property StartMode: TStartMode read FStartMode;
+    property ServerObjects:integer read fCountObject;
   end;
 
 var
   ComServer: TComServer = nil;
+  haut :TLibHandle;
 
+
 //http://msdn.microsoft.com/en-us/library/ms690368%28VS.85%29.aspx
 //If the function succeeds, the return value is S_OK. Otherwise, it is S_FALSE.
 function DllCanUnloadNow: HResult; stdcall;
@@ -219,9 +244,24 @@
 function TComServer.CountObject(Created: Boolean): Integer;
 begin
   if Created then
-    Result:=InterLockedIncrement(fCountObject)
+  begin
+    Result := InterlockedIncrement(FCountObject);
+    if (not IsInProcServer) and (StartMode = smAutomation)
+      and Assigned(ComObj.CoAddRefServerProcess) then
+      ComObj.CoAddRefServerProcess;
+  end
   else
-    Result:=InterLockedDecrement(fCountObject);
+  begin
+    Result := InterlockedDecrement(FCountObject);
+    if (not IsInProcServer) and (StartMode = smAutomation)
+      and Assigned(ComObj.CoReleaseServerProcess) then
+    begin
+      if ComObj.CoReleaseServerProcess() = 0 then
+        CheckReleased;
+    end
+    else if Result = 0 then
+      CheckReleased;
+  end;
 end;
 
 function TComServer.CountFactory(Created: Boolean): Integer;
@@ -232,6 +272,22 @@
     Result:=InterLockedDecrement(fCountFactory);
 end;
 
+procedure TComServer.FactoryFree(Factory: TComObjectFactory);
+begin
+  Factory.Free;
+end;
+
+procedure TComServer.FactoryRegisterClassObject(Factory: TComObjectFactory);
+begin
+  Factory.RegisterClassObject;
+end;
+
+procedure TComServer.FactoryUpdateRegistry(Factory: TComObjectFactory);
+begin
+  if Factory.Instancing <> ciInternal then
+    Factory.UpdateRegistry(FRegister);
+end;
+
 function TComServer.GetHelpFileName: string;
 begin
   result:=fhelpfilename;
@@ -244,14 +300,29 @@
 
 function TComServer.GetServerKey: string;
 begin
-  result:='LocalServer32';
+  if FIsInproc then
+    Result := 'InprocServer32'
+  else
+    Result := 'LocalServer32';
 end;
 
 function TComServer.GetServerName: string;
 begin
-  Result := fServerName;
+  if FServerName <> '' then
+    Result := FServerName
+  else
+    if FTypeLib <> nil then
+      Result := GetTypeLibName
+    else
+      Result := GetModuleName;
 end;
 
+function TComServer.GetTypeLibName: widestring;
+begin
+  OleCheck(TypeLib.GetDocumentation(-1, @Result, nil, nil, nil));
+end;
+
+
 function TComServer.GetStartSuspended: Boolean;
 begin
   result:=fStartSuspended;
@@ -262,6 +333,30 @@
   Result := fTypeLib;
 end;
 
+procedure TComServer.RegisterObjectWith(Factory: TComObjectFactory);
+begin
+  Factory.RegisterClassObject;
+end;
+
+
+procedure TComServer.Start;
+begin
+  case fStartMode of
+  smRegServer:
+    begin
+      Self.RegisterServer;
+      Halt;
+    end;
+  smUnregServer:
+    begin
+      Self.UnRegisterServer;
+      Halt;
+    end;
+  end;
+  ComClassManager.ForEachFactory(Self, @RegisterObjectWith);
+end;
+
+
 procedure TComServer.SetHelpFileName(const Value: string);
 begin
   FHelpFileName:=value;
@@ -277,10 +372,25 @@
   Factory.UpdateRegistry(False);
 end;
 
+procedure TComServer.CheckCmdLine;
+const
+  sw_set:TSysCharSet = ['/','-'];
+begin
+  if FindCmdLineSwitch('automation',sw_set,true) or
+     FindCmdLineSwitch('embedding',sw_set,true) then
+    fStartMode := smAutomation
+  else if FindCmdlIneSwitch('regserver',sw_set,true) then
+    fStartMode := smRegServer
+  else if FindCmdLineSwitch('unregserver',sw_set,true) then
+    fStartMode := smUnregServer;
+end;
+
 constructor TComServer.Create;
 var
   name: WideString;
 begin
+  haut := SafeLoadLibrary('oleaut32.DLL');
+  CheckCmdLine;
   inherited Create;
 {$ifdef DEBUG_COM}
   WriteLn('TComServer.Create');
@@ -288,6 +398,9 @@
   fCountFactory := 0;
   fCountObject := 0;
 
+  FTypeLib := nil;
+  FIsInproc := ModuleIsLib;
+
   fServerFileName := GetModuleFileName();
 
   name := fServerFileName;
@@ -301,11 +414,61 @@
   end
   else
     fServerName := GetModuleName;
+
+  if not ModuleIsLib then
+  begin
+    orgInitProc := InitProc;
+    InitProc := @TComServer.AutomationStart;
+  //  AddTerminateProc(TTerminateProc(@TComServer.AutomationDone));
+  end;
+
+  Self.FIsInteractive := True;
 end;
 
+class procedure TComServer.AutomationStart;
+begin
+  if orgInitProc <> nil then TProcedure(orgInitProc)();
+  ComServer.FStartSuspended := (CoInitFlags <> -1) and
+    Assigned(ComObj.CoInitializeEx) and Assigned(ComObj.CoResumeClassObjects);
+  ComServer.Start;
+  if ComServer.FStartSuspended then
+    ComObj.CoResumeClassObjects;
+end;
+
+class function TComServer.AutomationDone: Boolean;
+begin
+  Result := True;
+  if (ComServer <> nil) and (ComServer.ServerObjects > 0) and ComServer.IsInteractive then
+  begin
+    Result := MessageBox(0, PChar('COM server is in use'),
+      PChar('OLE Automation'), MB_YESNO or MB_TASKMODAL or
+      MB_ICONWARNING or MB_DEFBUTTON2) = IDYES;
+  end;
+end;
+
+
+procedure TComServer.CheckReleased;
+var
+  Shutdown: Boolean;
+begin
+  if not FIsInproc then
+  begin
+    Shutdown := FStartMode = smAutomation;
+    try
+      if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
+    finally
+      if Shutdown then PostThreadMessage(MainThreadID, WM_QUIT, 0, 0);
+    end;
+  end;
+end;
+
+
 destructor TComServer.Destroy;
 begin
+  ComClassManager.ForEachFactory(Self, @FactoryFree,true);
+  Self.fTypeLib:=nil;
   inherited Destroy;
+  FreeLibrary(haut);
 {$ifdef DEBUG_COM}
   WriteLn('TComServer.Destroy');
 {$endif}
@@ -332,15 +495,17 @@
   ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
 end;
 
+
 initialization
 {$ifdef DEBUG_COM}
   WriteLn('comserv initialization begin');
 {$endif}
   ComServer := TComServer.Create;
+
 {$ifdef DEBUG_COM}
   WriteLn('comserv initialization end');
 {$endif}
 finalization
-  ComServer.Free;
+  ComServer.AutomationDone;
+  FreeAndNil(ComServer);
 end.
-
35013.patch (12,969 bytes)

Anton Kavalenka

2019-07-27 17:38

reporter   ~0117436

Last edited: 2019-07-27 19:20

View 2 revisions

Sorry for line-endings, TortoiseSVN did this without my consent.
Fixes from Do-wan Kim are the proper-one.

Marco van de Voort

2019-08-06 14:03

manager   ~0117578

Last edited: 2019-08-06 14:03

View 2 revisions

Committed library parts as 42594, please verify

Some guidance on how to operate the demo. Nothing much seems to happen here, either with DXE4 or FPC. I credit that to my inexperience.

It would be worthwhile to have the demo as part of the winapi-base tests/examples. (can you give it other names then project1 and unit1? And some comments on how to register etc)

Anton Kavalenka

2019-08-07 15:08

reporter   ~0117587

Last edited: 2019-08-07 15:09

View 2 revisions

Instead of test.vbs functionally identical Pascal program can be written. The idea of test - call the COM object method with known result.

As far I remember - COM server program registers itself just being executed without any switches or with explicit /regserver

As soon I get the terminal - I will update test.

Anton Kavalenka

2019-08-16 18:10

reporter   ~0117706

Updated test com_test.zip
com_serv - OLE Automation server with two methods
com_clnt - Pascal program to call server methods

Server has to be registered before using client
com_serv /regserver - registers automation server
com_serv /unregserver - un-registers automation server

com_test.zip (4,736 bytes)

Marco van de Voort

2019-08-25 11:34

manager   ~0117830

works and committed in winunits-base/tests/inproccomtest.

Thanks for both the patch and the demo!

Issue History

Date Modified Username Field Change
2019-02-05 16:21 Anton Kavalenka New Issue
2019-02-05 16:21 Anton Kavalenka File Added: oleaut.zip
2019-02-07 17:26 Anton Kavalenka File Added: comobj.diff
2019-02-07 17:26 Anton Kavalenka File Added: comserv.diff
2019-02-07 17:26 Anton Kavalenka File Added: hconst.pas
2019-02-07 17:27 Anton Kavalenka Note Added: 0113929
2019-02-07 17:28 Anton Kavalenka File Added: oleaut1.zip
2019-02-09 14:42 Marco van de Voort File Deleted: hconst.pas
2019-02-09 14:43 Marco van de Voort Note Added: 0113981
2019-02-09 14:43 Marco van de Voort Note Added: 0113982
2019-02-09 16:42 Anton Kavalenka Note Added: 0113990
2019-02-09 16:46 Anton Kavalenka Note Edited: 0113990 View Revisions
2019-02-09 16:48 Anton Kavalenka Note Edited: 0113990 View Revisions
2019-07-19 15:34 Anton Kavalenka File Added: comobj-2.diff
2019-07-19 15:34 Anton Kavalenka File Added: comserv-2.diff
2019-07-19 15:34 Anton Kavalenka Note Added: 0117316
2019-07-19 16:36 Sven Barth Note Added: 0117318
2019-07-21 08:49 Do-wan Kim File Added: 35013.patch
2019-07-27 17:38 Anton Kavalenka Note Added: 0117436
2019-07-27 19:20 Anton Kavalenka Note Edited: 0117436 View Revisions
2019-08-06 14:03 Marco van de Voort Note Added: 0117578
2019-08-06 14:03 Marco van de Voort Note Edited: 0117578 View Revisions
2019-08-07 15:08 Anton Kavalenka Note Added: 0117587
2019-08-07 15:09 Anton Kavalenka Note Edited: 0117587 View Revisions
2019-08-16 18:10 Anton Kavalenka File Added: com_test.zip
2019-08-16 18:10 Anton Kavalenka Note Added: 0117706
2019-08-25 11:34 Marco van de Voort Assigned To => Marco van de Voort
2019-08-25 11:34 Marco van de Voort Status new => resolved
2019-08-25 11:34 Marco van de Voort Resolution open => fixed
2019-08-25 11:34 Marco van de Voort Fixed in Revision => 42594,42812
2019-08-25 11:34 Marco van de Voort FPCTarget => -
2019-08-25 11:34 Marco van de Voort Note Added: 0117830
2019-08-26 08:12 Anton Kavalenka Status resolved => closed