How to create functions in the type library
Automation methods are functions returning HRESULT, converted to procedures by Delphi safecall calling convention, that automatically manage HRESULTs.
In addition to in and out parameters, automation methods also support one retval parameter. Delphi converts methods with it to a safecall function using the parameter type as the result type of the function. The retval parameter must be the last one and, as an out parameter, has to be a pointer (e.g., long* instead of long for integers, BSTR* instead of BSTR for strings, ...).
So, if you declare in the type library editor a parameter with a pointer type and the out and retval modifiers, it will appear in the *_TLB.pas file as a safecall function. This is also the way that property getters are created.
Iterating thru window.external methods
As Noseratio said, the dispatch object must implement IDispatchEx.
I've made a library with two classes which extend TAutoIntfObject and TObjectDispatch so they implement the basic functionality of IDispatchEx.
So if you inherit your TWebBrowserBridge from TAutoIntfObjectEx instead of TAutoIntfObject, now the iterating will work.
To implement GetNextDispID and GetMemberName, both classes need to extract metadata about the methods of the class:
TAutoIntfObjectEx obtains it from the ITypeInfo provided by the type library.
TObjectDispatchEx obtains it from the extended RTTI provided by {$METHODINFO ON}.
This needs at least Delphi 2010. See my other answer for info on how to use TObjectDispatch.
The metadata is used in each iteration of the for in, so, for each class inherited from one of them, it is extracted the first time it's needed and cached for subsequent uses. This means a two-level cache: one for each subclass inherited from one of the extended classes, and other for the dispids and names of each subclass' methods.
I've used a somewhat rough approach with sorted TStringList and binary search for both caches. The first level can be replaced with an unsorted map (like a hashtable, e.g. TObjectDictionary in modern Delphi versions), but the second needs also ordering, so a sorted map (like a Red-black tree) is the right way.
unit LibDispatchEx;
interface
{$IFDEF CONDITIONALEXPRESSIONS}
{$IF CompilerVersion >= 21} // Delphi 2010+
{$DEFINE HAS_RTTI}
{$IFEND}
{$IF RTLVersion >= 15} // Delphi 7+
{$DEFINE HAS_DISPATCHEX}
{$IFEND}
{$ENDIF}
uses
Windows, SysUtils, Classes, ActiveX, ComObj{$ifdef HAS_RTTI}, ObjComAuto{$endif};
{$IFNDEF HAS_DISPATCHEX}
const
DISPID_STARTENUM = DISPID_UNKNOWN;
DISPATCH_CONSTRUCT = $4000;
type
IServiceProvider = interface(IUnknown)
['{6d5140c1-7436-11ce-8034-00aa006009fa}']
function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall;
end;
PServiceProvider = ^IServiceProvider;
IDispatchEx = interface(IDispatch)
['{A6EF9860-C720-11D0-9337-00A0C90DCAA9}']
function GetDispID(const bstrName: TBSTR; const grfdex: DWORD; out id: TDispID): HResult; stdcall;
function InvokeEx(const id: TDispID; const lcid: LCID; const wflags: WORD; const pdp: PDispParams; out varRes: OleVariant; out pei: TExcepInfo; const pspCaller: PServiceProvider): HResult; stdcall; function DeleteMemberByName(const bstr: TBSTR; const grfdex: DWORD): HResult; stdcall;
function DeleteMemberByDispID(const id: TDispID): HResult; stdcall; function GetMemberProperties(const id: TDispID; const grfdexFetch: DWORD; out grfdex: DWORD): HResult; stdcall;
function GetMemberName(const id: TDispID; out bstrName: TBSTR): HResult; stdcall;
function GetNextDispID(const grfdex: DWORD; const id: TDispID; out nid: TDispID): HResult; stdcall;
function GetNameSpaceParent(out unk: IUnknown): HResult; stdcall;
end;
{$ENDIF}
type
TDispatchExSubclass = class;
TAutoIntfObjectEx = class(TAutoIntfObject, IDispatchEx)
protected
FMetadata: TDispatchExSubclass;
procedure GetMetadata;
function GetDispID(const bstrName: TBSTR; const grfdex: DWORD; out id: TDispID): HResult; stdcall;
function InvokeEx(const id: TDispID; const lcid: LCID; const wflags: WORD; const pdp: PDispParams; out varRes: OleVariant; out pei: TExcepInfo; const pspCaller: PServiceProvider): HResult; stdcall;
function DeleteMemberByName(const bstr: TBSTR; const grfdex: DWORD): HResult; stdcall;
function DeleteMemberByDispID(const id: TDispID): HResult; stdcall;
function GetMemberProperties(const id: TDispID; const grfdexFetch: DWORD; out grfdex: DWORD): HResult; stdcall;
function GetMemberName(const id: TDispID; out bstrName: TBSTR): HResult; stdcall;
function GetNextDispID(const grfdex: DWORD; const id: TDispID; out nid: TDispID): HResult; stdcall;
function GetNameSpaceParent(out unk: IUnknown): HResult; stdcall;
end;
{$ifdef HAS_RTTI}
TObjectDispatchEx = class(TObjectDispatch, IDispatchEx)
protected
FMetadata: TDispatchExSubclass;
procedure GetMetadata;
function GetDispID(const bstrName: TBSTR; const grfdex: DWORD; out id: TDispID): HResult; stdcall;
function InvokeEx(const id: TDispID; const lcid: LCID; const wflags: WORD; const pdp: PDispParams; out varRes: OleVariant; out pei: TExcepInfo; const pspCaller: PServiceProvider): HResult; stdcall;
function DeleteMemberByName(const bstr: TBSTR; const grfdex: DWORD): HResult; stdcall;
function DeleteMemberByDispID(const id: TDispID): HResult; stdcall;
function GetMemberProperties(const id: TDispID; const grfdexFetch: DWORD; out grfdex: DWORD): HResult; stdcall;
function GetMemberName(const id: TDispID; out bstrName: TBSTR): HResult; stdcall;
function GetNextDispID(const grfdex: DWORD; const id: TDispID; out nid: TDispID): HResult; stdcall;
function GetNameSpaceParent(out unk: IUnknown): HResult; stdcall;
end;
{$endif}
TDispatchExSubclass = class
protected
DispIDCache: TStringList;
public
constructor Create;
destructor Destroy; override;
end;
// singleton class
TDispatchExMetadataCache = class
protected
SubclassCache: TStringList;
class function FormatInt(i: integer): string;
class function UnformatInt(i: string): integer;
public
constructor Create;
destructor Destroy; override;
function Add(subclass: TAutoIntfObjectEx): TDispatchExSubclass; overload;
{$ifdef HAS_RTTI}
function Add(subclass: TObjectDispatchEx): TDispatchExSubclass; overload;
{$endif}
end;
implementation
{$ifdef HAS_RTTI}
uses Rtti, TypInfo;
{$endif}
var
DispatchEx_MetadataCache: TDispatchExMetadataCache; // declare as "class var" of TDispatchExMetadataCache in modern Delphi
{ TDispatchExMetadataCache }
class function TDispatchExMetadataCache.FormatInt(i: integer): string;
begin
Result := IntToHex(i, 8);
end;
class function TDispatchExMetadataCache.UnformatInt(i: string): integer;
begin
Result := StrToInt('$'+i);
end;
constructor TDispatchExMetadataCache.Create;
begin
inherited;
SubclassCache := TStringList.Create; // use TObjectDictionary<string,TDispatchExSubclass> in modern Delphi
SubclassCache.Sorted := true; // activate binary search
end;
destructor TDispatchExMetadataCache.Destroy;
var
i: integer;
begin
for i := 0 to SubclassCache.Count - 1 do
SubclassCache.Objects[i].Free;
SubclassCache.Free;
inherited;
end;
function TDispatchExMetadataCache.Add(subclass: TAutoIntfObjectEx): TDispatchExSubclass;
var
i, f, cnt: integer;
pta: PTypeAttr;
pfd: PFuncDesc;
bstr: TBStr;
name: PString;
begin
i := SubclassCache.IndexOf(subclass.ClassName);
if i >= 0 then
Result := TDispatchExSubclass(SubclassCache.Objects[i])
else begin
Result := TDispatchExSubclass.Create;
SubclassCache.AddObject(subclass.ClassName, Result);
OleCheck(subclass.DispTypeInfo.GetTypeAttr(pta));
try
for f := 0 to pta^.cFuncs - 1 do begin
OleCheck(subclass.DispTypeInfo.GetFuncDesc(f, pfd));
try
if pfd.wFuncFlags and FUNCFLAG_FRESTRICTED = 0 then begin // exclude system-level methods
OleCheck(subclass.DispTypeInfo.GetNames(pfd.memid, @bstr, 1, cnt));
New(name);
name^ := bstr;
SysFreeString(bstr);
Result.DispIDCache.AddObject(FormatInt(pfd.memid), TObject(name));
end;
finally
subclass.DispTypeInfo.ReleaseFuncDesc(pfd);
end;
end;
finally
subclass.DispTypeInfo.ReleaseTypeAttr(pta);
end;
end;
end;
{$ifdef HAS_RTTI}
function GetNonSystemMethods(aType: TRttiType; aStopType: TRttiType): TArray<TRttiMethod>;
function Flatten(const Args: array of TArray<TRttiMethod>): TArray<TRttiMethod>;
var
i, j, r, len: Integer;
begin
len := 0;
for i := 0 to High(Args) do
len := len + Length(Args[i]);
SetLength(Result, len);
r := 0;
for i := 0 to High(Args) do begin
for j := 0 to High(Args[i]) do begin
Result[r] := Args[i][j];
Inc(r);
end;
end;
end;
var
nestedMethods: TArray<TArray<TRttiMethod>>;
t: TRttiType;
depth: Integer;
begin
t := aType;
depth := 0;
while (t <> nil) and (t <> aStopType) do begin
Inc(depth);
t := t.BaseType;
end;
SetLength(nestedMethods, depth);
t := aType;
depth := 0;
while (t <> nil) and (t <> aStopType) do begin
nestedMethods[depth] := t.GetDeclaredMethods;
Inc(depth);
t := t.BaseType;
end;
Result := Flatten(nestedMethods);
end;
function TDispatchExMetadataCache.Add(subclass: TObjectDispatchEx): TDispatchExSubclass;
var
obj: TObject;
i: integer;
ctx: TRttiContext;
t: TRttiType;
method: TRttiMethod;
name: PString;
begin
obj := subclass.Instance; // the real object inside the TObjectDispatch
i := SubclassCache.IndexOf(obj.ClassName);
if i >= 0 then
Result := TDispatchExSubclass(SubclassCache.Objects[i])
else begin
Result := TDispatchExSubclass.Create;
SubclassCache.AddObject(obj.ClassName, Result);
t := ctx.GetType(obj.ClassType);
for method in GetNonSystemMethods(t, ctx.GetType(TObject)) do begin // exclude system-level methods
New(name);
name^ := method.Name;
subclass.GetIDsOfNames(GUID_NULL, name, 1, 0, @i);
Result.DispIDCache.AddObject(FormatInt(i), TObject(name));
end;
end;
end;
{$endif}
{ TDispatchExSubclass }
constructor TDispatchExSubclass.Create;
begin
inherited;
DispIDCache := TStringList.Create;
DispIDCache.Sorted := true; // activate binary search
end;
destructor TDispatchExSubclass.Destroy;
var
i: integer;
begin
for i := 0 to DispIDCache.Count - 1 do
Dispose(PString(DispIDCache.Objects[i]));
DispIDCache.Free;
inherited;
end;
{ TAutoIntfObjectEx }
procedure TAutoIntfObjectEx.GetMetadata;
begin
if FMetadata = nil then
FMetadata := DispatchEx_MetadataCache.Add(self);
end;
function TAutoIntfObjectEx.DeleteMemberByDispID(const id: TDispID): HResult;
begin
Result := E_NOTIMPL;
end;
function TAutoIntfObjectEx.DeleteMemberByName(const bstr: TBSTR; const grfdex: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TAutoIntfObjectEx.GetDispID(const bstrName: TBSTR; const grfdex: DWORD; out id: TDispID): HResult;
begin
// TO-DO: implement support for fdexNameEnsure and fdexNameImplicit if desired
Result := GetIDsOfNames(GUID_NULL, @bstrName, 1, 0, @id);
end;
function TAutoIntfObjectEx.GetMemberName(const id: TDispID; out bstrName: TBSTR): HResult;
var
i: integer;
begin
GetMetadata;
i := FMetadata.DispIDCache.IndexOf(TDispatchExMetadataCache.FormatInt(id));
if i >= 0 then begin
bstrName := SysAllocString(PWideChar(WideString(PString(FMetadata.DispIDCache.Objects[i])^)));
Result := S_OK;
end
else
Result := DISP_E_UNKNOWNNAME;
end;
function TAutoIntfObjectEx.GetMemberProperties(const id: TDispID; const grfdexFetch: DWORD; out grfdex: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TAutoIntfObjectEx.GetNameSpaceParent(out unk: IUnknown): HResult;
begin
Result := E_NOTIMPL;
end;
function TAutoIntfObjectEx.GetNextDispID(const grfdex: DWORD; const id: TDispID; out nid: TDispID): HResult;
var
i: integer;
begin
Result := S_FALSE;
GetMetadata;
if id = DISPID_STARTENUM then begin
if FMetadata.DispIDCache.Count > 0 then begin
nid := TDispatchExMetadataCache.UnformatInt(FMetadata.DispIDCache[0]);
Result := S_OK;
end;
end
else begin
i := FMetadata.DispIDCache.IndexOf(TDispatchExMetadataCache.FormatInt(id));
if (i >= 0) and (i < FMetadata.DispIDCache.Count - 1) then begin
nid := TDispatchExMetadataCache.UnformatInt(FMetadata.DispIDCache[i+1]);
Result := S_OK;
end;
end;
end;
function TAutoIntfObjectEx.InvokeEx(const id: TDispID; const lcid: LCID; const wflags: WORD; const pdp: PDispParams; out varRes: OleVariant; out pei: TExcepInfo; const pspCaller: PServiceProvider): HResult;
begin
if wflags = DISPATCH_CONSTRUCT then // TO-DO: implement constructor semantics if desired
Result := DISP_E_MEMBERNOTFOUND
else begin
{ TO-DO: support "this" parameter if desired.
From MSDN:
When DISPATCH_METHOD is set in wFlags, there may be a "named parameter" for the "this" value.
The DISPID will be DISPID_THIS and it must be the first named parameter.
}
Result := Invoke(id, GUID_NULL, lcid, wflags, pdp^, @varRes, @pei, nil);
end;
end;
{$ifdef HAS_RTTI}
{ TObjectDispatchEx }
procedure TObjectDispatchEx.GetMetadata;
begin
if FMetadata = nil then
FMetadata := DispatchEx_MetadataCache.Add(self);
end;
function TObjectDispatchEx.DeleteMemberByDispID(const id: TDispID): HResult;
begin
Result := E_NOTIMPL;
end;
function TObjectDispatchEx.DeleteMemberByName(const bstr: TBSTR; const grfdex: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TObjectDispatchEx.GetDispID(const bstrName: TBSTR; const grfdex: DWORD; out id: TDispID): HResult;
begin
// TO-DO: implement support for fdexNameEnsure and fdexNameImplicit if desired
Result := GetIDsOfNames(GUID_NULL, @bstrName, 1, 0, @id);
end;
function TObjectDispatchEx.GetMemberName(const id: TDispID; out bstrName: TBSTR): HResult;
var
i: integer;
begin
GetMetadata;
i := FMetadata.DispIDCache.IndexOf(TDispatchExMetadataCache.FormatInt(id));
if i >= 0 then begin
bstrName := SysAllocString(PWideChar(WideString(PString(FMetadata.DispIDCache.Objects[i])^)));
Result := S_OK;
end
else
Result := DISP_E_UNKNOWNNAME;
end;
function TObjectDispatchEx.GetMemberProperties(const id: TDispID; const grfdexFetch: DWORD; out grfdex: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TObjectDispatchEx.GetNameSpaceParent(out unk: IUnknown): HResult;
begin
Result := E_NOTIMPL;
end;
function TObjectDispatchEx.GetNextDispID(const grfdex: DWORD; const id: TDispID; out nid: TDispID): HResult;
var
i: integer;
begin
Result := S_FALSE;
GetMetadata;
if id = DISPID_STARTENUM then begin
if FMetadata.DispIDCache.Count > 0 then begin
nid := TDispatchExMetadataCache.UnformatInt(FMetadata.DispIDCache[0]);
Result := S_OK;
end;
end
else begin
i := FMetadata.DispIDCache.IndexOf(TDispatchExMetadataCache.FormatInt(id));
if (i >= 0) and (i < FMetadata.DispIDCache.Count - 1) then begin
nid := TDispatchExMetadataCache.UnformatInt(FMetadata.DispIDCache[i+1]);
Result := S_OK;
end;
end;
end;
function TObjectDispatchEx.InvokeEx(const id: TDispID; const lcid: LCID; const wflags: WORD; const pdp: PDispParams; out varRes: OleVariant; out pei: TExcepInfo; const pspCaller: PServiceProvider): HResult;
begin
if wflags = DISPATCH_CONSTRUCT then // TO-DO: implement constructor semantics if desired
Result := DISP_E_MEMBERNOTFOUND
else begin
{ TO-DO: support "this" parameter if desired.
From MSDN:
When DISPATCH_METHOD is set in wFlags, there may be a "named parameter" for the "this" value.
The DISPID will be DISPID_THIS and it must be the first named parameter.
}
Result := Invoke(id, GUID_NULL, lcid, wflags, pdp^, @varRes, @pei, nil);
end;
end;
{$endif}
initialization
DispatchEx_MetadataCache := TDispatchExMetadataCache.Create; // put in class constructor of TDispatchExMetadataCache in modern Delphi
finalization
DispatchEx_MetadataCache.Free; // put in class destructor of TDispatchExMetadataCache in modern Delphi
end.
