paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-02 20:19:34 +01:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@14947 -
This commit is contained in:
paul 2010-02-27 08:05:51 +00:00
parent fcaac0ebe1
commit 9aa4504369
2 changed files with 78 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
rtl/objpas/classes/classesh.inc
View File

@ -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;

73
rtl/objpas/classes/compon.inc
View File

@ -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 GetInterface(IID, Obj) then
result:=S_OK
if Assigned(VCLComObject) then
Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
else
result:=E_NOINTERFACE;
if GetInterface(IID, Obj) then
Result := S_OK
else
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;