Calling IDispatch directly

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.

 

Share this article!

Follow us!

Find more helpful articles: