Mega Code Archive
Calling idispatch directly
<![CDATA[
How to incorporate simple scripting capabilities into Delphi. It might prove useful to call a method, described as string, on an interface, defined by a string containing something like 'MyLib.MyObject1'.
This unit exposes a few function that you can call to access IDispatch interface more easily.
-------------------------------
{////////////////////////////////////////////////////////////////
Name of unit: DispatchLib
Purpose of unit:
Exposes function to manipulate COM objects that implement
IDispatch interface.
You can call methods or properties directly or you can
list all the functions to a TStringList object.
An example:
procedure fa(sl: TStringList);
var
a: variant;
s: string;
begin
a := CreateOLEObject("microsoft.msxml");
DocumentIDispatch(a, sl);
ExecuteOnDispatchMultiParam(a, "loadxml", ["b"]);
s := ExecuteOnDispatchMultiParam(a, "xml", []);
MessageDlg(s, mtInformation, [mbOk], 0);
end;
Code is based on a unit I found on the internet, but it contained
some serious bugs and it didn't support more than one parameter.
Anything unusual:
Coded by: VJ
Date: 17.07.2001
Revision history:
////////////////////////////////////////////////////////////////}
unit DispatchLib;
interface
uses
ActiveX,
sysutils,
classes;
type
exMethodNotSupported = class(Exception);
exIDispatchCallError = class(Exception);
function ExecuteOnDispatchMultiParam(TargetObj: IDispatch; MethodName: string; ParamValues: array of const): OleVariant;
procedure DocumentIDispatch(ID: IDispatch; var SL: TStringList);
procedure DocumentIDispatch2(ID: IDispatch; var SLNames: TStringList);
function ElementDescriptionToString(a: TElemDesc): string;
implementation
function ElementDescriptionToString(a: TElemDesc): string;
begin
case a.tdesc.vt of
VT_I4: Result := 'int';
VT_R8: Result := 'double';
VT_BSTR: Result := 'string';
else
Result := '';
end;
end;
procedure DocumentIDispatch(ID: IDispatch; var SL: TStringList);
var
res: HResult;
Count, loop, loop2, loop3: integer;
TI: ITypeinfo;
pTA: PTypeAttr;
pFD: PFuncDesc;
varDesc: pVarDesc;
numFunctions: integer;
numParams: integer;
funcDispID: integer;
names: TBStrList;
numReturned: integer;
functionstr: widestring;
hide: boolean;
begin
assert(SL <> nil, 'SL may not be nil');
SL.Clear;
res := ID.GetTypeInfoCount(Count);
if succeeded(res) then begin
for loop := 0 to Count - 1 do begin
res := ID.GetTypeInfo(loop, 0, TI);
if succeeded(res) then begin
res := TI.GetTypeAttr(pTA);
if succeeded(res) then begin
if pTA^.typekind = TKIND_DISPATCH then begin
numFunctions := pTA^.cFuncs;
for loop2 := 0 to numFunctions - 1 do begin
res := TI.GetFuncDesc(loop2, pFD);
if succeeded(res) then begin
funcDispID := pFD^.memid;
numParams := pFD^.cParams;
res := TI.GetNames(funcDispID, @names, numParams + 1, numReturned);
if succeeded(res) then begin
functionstr := '';
if numReturned > 0 then
functionstr := functionstr + names[0];
if numReturned > 1 then begin
functionstr := functionStr + '(';
for loop3 := 1 to numReturned - 1 do begin
if loop3 > 1 then
functionstr := functionstr + ', ';
functionstr :=
functionstr +
names[loop3] + ':' +
ElementDescriptionToString(pFD^.lprgelemdescParam^[loop3 - 1]);
end;
//functionstr := functionstr + names[numReturned - 1] + ')';
functionstr := functionstr + ')';
end;
hide := False;
// Hides the non-dispatch functions
if (pFD^.wFuncFlags and FUNCFLAG_FRESTRICTED) = FUNCFLAG_FRESTRICTED then
hide := True;
// Hides the functions not intended for scripting: basically redundant functions
if (pFD^.wFuncFlags and FUNCFLAG_FHIDDEN) = FUNCFLAG_FHIDDEN then
hide := True;
if not hide then
SL.add(functionstr);
end;
TI.ReleaseFuncDesc(pFD);
end;
end;
end;
TI.ReleaseTypeAttr(pTA);
end;
end;
end;
end
else
raise Exception.Create('GetTypeInfoCount Failed');
end;
procedure DocumentIDispatch2(ID: IDispatch; var SLNames: TStringList);
var
res: HResult;
Count, loop, loop2, loop3: integer;
TI: ITypeinfo;
pTA: PTypeAttr;
pFD: PFuncDesc;
varDesc: pVarDesc;
numFunctions: integer;
numParams: integer;
funcDispID: integer;
names: TBStrList;
numReturned: integer;
functionstr: widestring;
hide: boolean;
begin
SLNames.Clear;
res := ID.GetTypeInfoCount(Count);
if succeeded(res) then begin
for loop := 0 to Count - 1 do begin
res := ID.GetTypeInfo(loop, 0, TI);
if succeeded(res) then begin
res := TI.GetTypeAttr(pTA);
if succeeded(res) then begin
if pTA^.typekind = TKIND_DISPATCH then begin
numFunctions := pTA^.cFuncs;
for loop2 := 0 to numFunctions - 1 do begin
res := TI.GetFuncDesc(loop2, pFD);
if not succeeded(res) then
Continue;
funcDispID := pFD^.memid;
numParams := pFD^.cParams;
res := TI.GetNames(funcDispID, @names, numParams + 1, numReturned);
if not succeeded(res) then begin
TI.ReleaseFuncDesc(pFD);
Continue;
end;
// Hides the non-dispatch functions
if (pFD^.wFuncFlags and FUNCFLAG_FRESTRICTED) = FUNCFLAG_FRESTRICTED then
Continue;
// Hides the functions not intended for scripting: basically redundant functions
if (pFD^.wFuncFlags and FUNCFLAG_FHIDDEN) = FUNCFLAG_FHIDDEN then
Continue;
functionstr := '';
if numReturned > 0 then begin
functionstr := functionstr + names[0];
end;
functionstr := functionstr + '(';
if numReturned > 1 then begin
for loop3 := 1 to numReturned - 1 do begin
if loop3 > 1 then
functionstr := functionstr + ',';
functionstr :=
functionstr +
ElementDescriptionToString(pFD^.lprgelemdescParam^[loop3 - 1]);
end;
end;
SLNames.Add(functionstr + ')');
TI.ReleaseFuncDesc(pFD);
end;
end;
TI.ReleaseTypeAttr(pTA);
end;
end;
end;
end
else
raise Exception.Create('GetTypeInfoCount Failed');
end;
{////////////////////////////////////////////////////////////////
Name: ExecuteOnDispatchMultiParam
Purpose:
To execute arbitrary method on given COM object.
Author: VJ
Date: 07.07.2001
History:
////////////////////////////////////////////////////////////////}
function ExecuteOnDispatchMultiParam(
TargetObj: IDispatch;
MethodName: string;
ParamValues: array of const): OleVariant;
var
wide: widestring;
disps: TDispIDList;
panswer: ^olevariant;
answer: olevariant;
dispParams: TDispParams;
aexception: TExcepInfo;
pVarArg: PVariantArgList;
res: HResult;
ParamCount, i: integer;
begin
Result := false;
// prepare for function call
ParamCount := High(ParamValues) + 1;
wide := MethodName;
pVarArg := nil;
if ParamCount > 0 then
GetMem(pVarArg, ParamCount * sizeof(TVariantArg));
try
// get dispid of requested method
if not succeeded(TargetObj.GetIDsOfNames(GUID_NULL, @wide, 1, 0, @disps)) then
raise exMethodNotSupported.Create('This object does not support this method');
pAnswer := @answer;
// prepare parameters
for i := 0 to ParamCount - 1 do begin
case ParamValues[ParamCount - 1 - i].VType of
vtInteger: begin
pVarArg^[i].vt := VT_I4;
pVarArg^[i].lVal := ParamValues[ParamCount - 1 - i].VInteger;
end;
vtExtended: begin
pVarArg^[i].vt := VT_R8;
pVarArg^[i].dblVal := ParamValues[ParamCount - 1 - i].VExtended^;
end;
vtString, vtAnsiString, vtChar: begin
pVarArg^[i].vt := VT_BSTR;
pVarArg^[i].bstrVal := PWideChar(WideString(PChar(ParamValues[ParamCount - 1 - i].VString)));
end;
else
raise Exception.CreateFmt('Unsuported type for parameter with index %d', [i]);
end;
end;
// prepare dispatch parameters
dispparams.rgvarg := pVarArg;
dispparams.rgdispidNamedArgs := nil;
dispparams.cArgs := ParamCount;
dispparams.cNamedArgs := 0;
// make IDispatch call
res := TargetObj.Invoke(disps[0],
GUID_NULL, 0, DISPATCH_METHOD or DISPATCH_PROPERTYGET,
dispParams, pAnswer, @aexception, nil);
// check the result
if res <> 0 then
raise exIDispatchCallError.CreateFmt(
'Method call unsuccessfull. %s (%s).',
[string(aexception.bstrDescription), string(aexception.bstrSource)]);
// return the result
Result := answer;
finally
if ParamCount > 0 then
FreeMem(pVarArg, ParamCount * sizeof(TVariantArg));
end;
end;
end.
]]>