rtl: use CreateVCLComObject routing to create VCLComObject in case it is not assigned + test

git-svn-id: trunk@14948 -

.gitattributes

@@ -9360,6 +9360,7 @@ tests/test/umacpas1.pp svneol=native#text/plain
 tests/test/umainnam.pp svneol=native#text/plain
 tests/test/units/classes/tmakeobjinst.pp svneol=native#text/plain
 tests/test/units/classes/tsetstream.pp svneol=native#text/plain
+tests/test/units/classes/tvclcomobject.pp svneol=native#text/plain
 tests/test/units/crt/tcrt.pp svneol=native#text/plain
 tests/test/units/crt/tctrlc.pp svneol=native#text/plain
 tests/test/units/dos/hello.pp svneol=native#text/plain

rtl/objpas/classes/classesh.inc

@@ -1873,8 +1873,8 @@ var
   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass);
 {!!!!  RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
     AxRegType: TActiveXRegType) = nil;
-  CurrentGroup: Integer = -1;
+  CurrentGroup: Integer = -1;}
-  CreateVCLComObjectProc: procedure(Component: TComponent) = nil;}
+  CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
 
 { Point and rectangle constructors }
 

rtl/objpas/classes/compon.inc

@@ -40,9 +40,17 @@ end;
 
 function TComponent.GetComObject: IUnknown;
 begin
+  { Check if VCLComObject is not assigned - we need to create it by    }
+  { the call to CreateVCLComObject routine. If in the end we are still }
+  { have no valid VCLComObject pointer we need to raise an exception   }
   if not Assigned(VCLComObject) then
-    raise EComponentError.Create(SNoComSupport);
+    begin
-  // VCLComObject is IVCComObject but we need to return IUnknown
+      if Assigned(CreateVCLComObjectProc) then
+        CreateVCLComObjectProc(Self);
+      if not Assigned(VCLComObject) then
+        raise EComponentError.CreateFmt(SNoComSupport,[Name]);
+    end;
+  { VCLComObject is IVCComObject but we need to return IUnknown }
   IVCLComObject(VCLComObject).QueryInterface(IUnknown, Result);
 end;
 

tests/test/units/classes/tvclcomobject.pp

@@ -0,0 +1,76 @@
+program vclcomobject;
+
+{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+{$APPTYPE CONSOLE}
+
+uses
+  SysUtils, Classes;
+
+type
+  TDummyVCLComObject = class(TInterfacedObject, IVCLComObject)
+  public
+    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+    function SafeCallException(ExceptObject: TObject;
+      ExceptAddr: Pointer): HResult; override;
+    procedure FreeOnRelease;
+  end;
+var
+  c: TComponent;
+  v: IVCLComObject;
+
+procedure DoCreateVCLComObject(Component: TComponent);
+begin
+  Component.VCLComObject := Pointer(V);
+end;
+
+{ TDummyVCLComObject }
+
+procedure TDummyVCLComObject.FreeOnRelease;
+begin
+
+end;
+
+function TDummyVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.GetTypeInfo(Index, LocaleID: Integer;
+  out TypeInfo): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.Invoke(DispID: Integer; const IID: TGUID;
+  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+  ArgErr: Pointer): HResult;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TDummyVCLComObject.SafeCallException(ExceptObject: TObject;
+  ExceptAddr: Pointer): HResult;
+begin
+  Result := E_UNEXPECTED;
+end;
+
+begin
+  v := TDummyVCLComObject.Create;
+  CreateVCLComObjectProc := @DoCreateVCLComObject;
+  c := TComponent.Create(nil);
+  if c.ComObject = nil then
+    halt(1);
+  c.Free;
+  v := nil;
+end.