Usage case (some info first):
I have made some HTML/CSS3/Javascript games that can run on different platforms in WebView/Embedded browser in a platform specific executable. I have designed it myself because I am tired of all the 'frameworks' that be around that told me how simple it is to use their framework. I don't need all the bloat of these frameworks with their impressive classes and stuff, it must be simple as ABC, right? Also because a webview is slower than native code, it must be simple and straight to get the best performance.
So I designed an interface that comes available as variable in javascript, no need to load an extra javascript class (like cordova or phonegap or others). Because I also work with Windows (Windows does not have the possibility to change the name of the object variable to 'publish'), it is accessible by javascript via window.external. This variable will be an object when the html is loaded inside a webview/browser.
Question
This all works pretty well (on different platforms) but the window.external variable seems to be an empty object on Windows, but when you try to call a function like window.external.vibrate(500) it will be executed without error (this function exists in all platform versions of this object).
However, something like typeof window.external.vibrate results in 'undefined'. Traversing the object does nothing, for example:
for( var p in window.external ) {
alert( p );
}
Because of this it is not easy to to test if the external object is a 'real' external object and it is not possible to see what functions are supported (if necessary).
What can I do about this? Do I miss something inhere?
To give you some information, I have followed this 'guide':
http://www.delphidabbler.com/articles?article=22.
My code (simplified):
type library:
unit WebBrowserBridge_TLB;
// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //
// PASTLWTR : $Revision: 1.88.1.0.1.0 $
// File generated on 4-3-2014 6:50:23 from Type Library described below.
// ************************************************************************ //
// Type Lib: ExternalInterface\WebBrowserBridge.tlb (1)
// IID\LCID: {517F7078-5E73-4E5A-A8A2-8F0FF14EF21B}\0
// Helpfile:
// DepndLst:
// (1) v2.0 stdole, (C:\Windows\SysWOW64\stdole2.tlb)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
interface
uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
WebBrowserBridgeMajorVersion = 1;
WebBrowserBridgeMinorVersion = 0;
LIBID_WebBrowserBridge: TGUID = '{517F7078-5E73-XXXX-B8A2-8F0FF14EF21B}';
IID_IWebBrowserBridge: TGUID = '{4F995D09-XXXX-4042-993E-C71A8AED661E}';
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
IWebBrowserBridge = interface;
IWebBrowserBridgeDisp = dispinterface;
// *********************************************************************//
// Interface: IWebBrowserBridge
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {4F995D09-CF9E-XXX-993E-C71A8AED661E}
// *********************************************************************//
IWebBrowserBridge = interface(IDispatch)
['{4F995D09-CF9E-4042XXXX-C71A8AED661E}']
procedure isAvailable; safecall;
procedure vibrate(ms: Integer); safecall;
end;
// *********************************************************************//
// DispIntf: IWebBrowserBridgeDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {4F995D09-CF9E-XXX-993E-C71A8AED661E}
// *********************************************************************//
IWebBrowserBridgeDisp = dispinterface
['{4F995D09-CF9E-404XXXE-C71A8AED661E}']
procedure isAvailable; dispid 200;
procedure vibrate(ms: Integer); dispid 201;
end;
implementation
uses ComObj;
end.
Object library (class):
unit WebBrowserBridge;
interface
uses
// Delphi
ActiveX, SHDocVw, Windows, Classes, ComObj, Dialogs,
// Project
IntfDocHostUIHandler, UNulContainer, WebBrowserBridge_TLB;
type
TWebBrowserBridge = class(TAutoIntfObject, IWebBrowserBridge, IDispatch)
public
{ IMyExternal methods }
procedure isAvailable(); safecall;
procedure vibrate(ms: Integer); safecall;
public
constructor Create;
destructor Destroy; override;
end;
{
TWebBrowserBridgeContainer:
UI handler that extends browser's external object.
}
TWebBrowserBridgeContainer = class(TNulWBContainer, IDocHostUIHandler, IOleClientSite)
private
fExternalObj: IDispatch; // external object implementation
protected
{ Re-implemented IDocHostUIHandler method }
function GetExternal(out ppDispatch: IDispatch): HResult; stdcall;
public
constructor Create(const WBDefaultInterface: IDispatch);
end;
implementation
uses
SysUtils, StdActns;
{ TWebBrowserBridgeContainer }
constructor TWebBrowserBridgeContainer.Create(const WBDefaultInterface: IDispatch);
begin
inherited;
fExternalObj := TWebBrowserBridge.Create;
end;
function TWebBrowserBridgeContainer.GetExternal(out ppDispatch: IDispatch): HResult;
begin
ppDispatch := fExternalObj;
Result := S_OK; // indicates we've provided script
end;
{ TWebBrowserBridge }
constructor TWebBrowserBridge.Create;
var
TypeLib: ITypeLib; // type library information
ExeName: WideString; // name of our program's exe file
begin
// Get name of application
ExeName := ParamStr(0);
// Load type library from application's resources
OleCheck(LoadTypeLib(PWideChar(ExeName), TypeLib));
// Call inherited constructor
inherited Create(TypeLib, IWebBrowserBridge);
end;
destructor TWebBrowserBridge.Destroy;
begin
inherited;
end;
procedure TWebBrowserBridge.isAvailable();
begin
//Result:=1;
end;
procedure TWebBrowserBridge.vibrate(ms: Integer);
begin
windows.beep( 100, ms );
//showMessage( IntToStr( ms ));
end;
PS:
I also want to know how to create a function in the type library because it only allows to create procedures or properties (but properties are not supported like on Android).
EDIT:
See also my answer but question is still open because of the PS above.
It is possible to use a much simpler approach to implement external methods in Delphi, using the late-bound functionality provided by ObjComAuto.TObjectDispatch.
This way you don't need to define any interfaces nor a type library. All what you need is a simple class implementing the desired events, and the extended RTTI info provided by $METHODINFO.
You can implement procedures and functions, and receive Delphi types or javascript objects as parameters. Javascript objects can also be used from Delphi (both properties and methods can be accessed).
Example: (just drop a TEmbeddedWB in a form)
uses MSHTML_EWB, ObjComAuto;
type
{$METHODINFO ON} // activate detailed RTTI
TJavascriptReceiver = class
procedure MyMouseMove(event: variant);
procedure MyClick(event: variant);
function MyGet(msg: string): string;
end;
{$METHODINFO OFF}
{ TJavascriptReceiver }
procedure TJavascriptReceiver.MyMouseMove(event: variant);
begin
Form1.Caption := IntToStr(event.clientX) + ', ' + IntToStr(event.clientY);
end;
procedure TJavascriptReceiver.MyClick(event: variant);
var
w: variant;
begin
w := (Form1.EmbeddedWB1.Document as IHTMLDocument2).parentWindow;
w.testGet('Caption: ');
end;
function TJavascriptReceiver.MyGet(msg: string): string;
begin
Result := msg + Form1.Caption;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var
strs: TStringStream;
begin
strs := TStringStream.Create;
try
strs.WriteString(
'<!DOCTYPE html>'
+'<html>'
+'<head>'
+' <style>'
+' html, body { margin: 0; padding: 0; height: 100%; }'
+' </style>'
+' <script>'
+' function testGet(msg) {'
+' alert(external.MyGet(msg));'
+' }'
+' </script>'
+'</head>'
+'<body'
+' onmousemove="external.MyMouseMove(event)"'
+' onclick="external.MyClick(event)"'
+'>'
+'Click anywhere'
+'</body>'
+'</html>'
);
EmbeddedWB1.LoadFromStream(strs);
finally
strs.Free;
end;
end;
procedure TForm1.EmbeddedWB1GetExternal(Sender: TCustomEmbeddedWB;
var ppDispatch: IDispatch);
begin
ppDispatch := TObjectDispatch.Create(TJavascriptReceiver.Create);
end;
Note:
Javascript arrays are sparse, so you can't access them from Delphi using the usual myArray[3] syntax. Instead you need to use the index as if it were a property, i.e. some kind of myArray.3. This is not directly supported by Delphi, but using ComObj.GetDispatchPropValue: GetDispatchPropValue(myArray, '3'). More info here.
Edit:
See my other answer for info on how to iterate thru window.external methods.
To get this working:
for( var p in window.external ) {
alert( p );
}
You would need to implement IDispatchEx on your external object, specifically IDispatchEx::GetNextDispID and IDispatchEx::GetMemberName. This is how JavaScript iterates through COM object properties.
You could find some more details about IDispatchEx here.
It's not a real answer because it doesn't explain why traversing the object is not possible (but there is some explanation in the answer of Noseratio but unable to get it done myself so not able to verify it), but okay I can test if some function exists by using the following javascript code:
if( typeof window.external == 'object' && ('vibrate' in window.external))
{ window.external.vibrate(1000); }
When you take a look at the example above, it is weird that the following code doesn't work (because of the 'in' operator):
// does not work
for( var p in window.external ) {
alert( p );
}
Because Firefox does also implement a window.external object but with other intent (see also: https://developer.mozilla.org/en-US/docs/Adding_search_engines_from_web_pages), I check for the function 'isAvailable' that will be exported by the javascript external interface. To check if it is a real interface object, I do the following (the variable 'o' is an object):
o.gIsExternal = function() // Runs inside an executable webview/webbrowser object?
{
// Do test only once
if( typeof o.gdata.isExternal != 'boolean')
{
o.gdata.isExternal = false;
// When it fails to call isAvailable() it is not there
try { window.external.isAvailable();
o.gdata.isExternal = true;
}
catch(e) {}
}
return o.gdata.isExternal;
};
If you know a better solution please let me know.
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.
