rtl: initial TComponent.VCLComObject support - map interface related TComponent methods to the appropriate IVCLComObject interface methods

git-svn-id: trunk@14947 -

rtl/objpas/classes/classesh.inc

@@ -1528,21 +1528,17 @@ type
     csTransient);
   TGetChildProc = procedure (Child: TComponent) of object;
 
-  {
-  TComponentName = type string;
-
   IVCLComObject = interface
-    function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
-    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
+    ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
+    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): Integer; stdcall;
+      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
-      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
-    function SafeCallException(ExceptObject: TObject;
-      ExceptAddr: Pointer): Integer;
+      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+    function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult;
     procedure FreeOnRelease;
   end;
-  }
 
   IInterfaceComponentReference = interface 
     ['{3FEEC8E1-E400-4A24-BCAC-1F01476439B1}']
@@ -1580,7 +1576,7 @@ type
     FDesignInfo: Longint;
     FVCLComObject: Pointer;
     FComponentState: TComponentState;
-    // function GetComObject: IUnknown;
+    function GetComObject: IUnknown;
     function GetComponent(AIndex: Integer): TComponent;
     function GetComponentCount: Integer;
     function GetComponentIndex: Integer;
@@ -1627,12 +1623,12 @@ type
     function _Release: Integer; stdcall;
     function iicrGetComponent: TComponent;
     { IDispatch }
-    //!!!! function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
-    //!!!! function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
-    //!!!! function GetIDsOfNames(const IID: TGUID; Names: Pointer;
-    //!!!!   NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
-    //!!!! function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
-    //!!!!   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
+    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;
   public
     //!! Moved temporary
     // fpdoc doesn't handle this yet :(
@@ -1660,7 +1656,7 @@ type
       ExceptAddr: Pointer): HResult; override;
     procedure SetSubComponent(ASubComponent: Boolean);
     function UpdateAction(Action: TBasicAction): Boolean; dynamic;
-    // property ComObject: IUnknown read GetComObject;
+    property ComObject: IUnknown read GetComObject;
     function IsImplementorOf (const Intf:IInterface):boolean;
     procedure ReferenceInterface(const intf:IInterface;op:TOperation);
     property Components[Index: Integer]: TComponent read GetComponent;

rtl/objpas/classes/compon.inc

@@ -38,6 +38,14 @@ end;
 {*                             TComponent                                   *}
 {****************************************************************************}
 
+function TComponent.GetComObject: IUnknown;
+begin
+  if not Assigned(VCLComObject) then
+    raise EComponentError.Create(SNoComSupport);
+  // VCLComObject is IVCComObject but we need to return IUnknown
+  IVCLComObject(VCLComObject).QueryInterface(IUnknown, Result);
+end;
+
 Function  TComponent.GetComponent(AIndex: Integer): TComponent;
 
 begin
@@ -563,9 +571,9 @@ end;
 
 
 Procedure TComponent.FreeOnRelease;
-
 begin
-  // Delphi compatibility only at the moment.
+  if Assigned(VCLComObject) then
+    IVCLComObject(VCLComObject).FreeOnRelease;
 end;
 
 
@@ -609,9 +617,11 @@ end;
 
 Function  TComponent.SafeCallException(ExceptObject: TObject;
   ExceptAddr: Pointer): HResult;
-
 begin
-  SafeCallException:=inherited SafeCallException(ExceptObject, ExceptAddr);
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).SafeCallException(ExceptObject, ExceptAddr)
+  else
+    Result := inherited SafeCallException(ExceptObject, ExceptAddr);
 end;
 
 procedure TComponent.SetSubComponent(ASubComponent: Boolean);
@@ -636,20 +646,29 @@ end;
 
 function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
 begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
+  else
   if GetInterface(IID, Obj) then
-    result:=S_OK
+    Result := S_OK
   else
-    result:=E_NOINTERFACE;
+    Result := E_NOINTERFACE;
 end;
 
 function TComponent._AddRef: Integer;stdcall;
 begin
-  result:=-1;
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject)._AddRef
+  else
+    Result := -1;
 end;
 
 function TComponent._Release: Integer;stdcall;
 begin
-  result:=-1;
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject)._Release
+  else
+    Result := -1;
 end;
 
 function TComponent.iicrGetComponent: TComponent;
@@ -657,3 +676,39 @@ function TComponent.iicrGetComponent: TComponent;
 begin
   result:=self;
 end;
+
+function TComponent.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetTypeInfoCount(Count)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetTypeInfo(Index, LocaleID, TypeInfo)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
+  LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs)
+  else
+    Result := E_NOTIMPL;
+end;
+
+function TComponent.Invoke(DispID: Integer; const IID: TGUID;
+  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+  ArgErr: Pointer): HResult; stdcall;
+begin
+  if Assigned(VCLComObject) then
+    Result := IVCLComObject(VCLComObject).Invoke(DispID, IID, LocaleID, Flags, Params,
+      VarResult, ExcepInfo, ArgErr)
+  else
+    Result := E_NOTIMPL;
+end;