Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

COM: CallByName

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • COM: CallByName

    Yet another way of calling COM methods and properties.
    Save it as CallByName.INC

    18 May 2006: Modified to add the instruction udt_DispParams.CountNamed = 1
    See article at http://www.forum.it-berater.org/index.php?topic=21.0
    and discussion about the missing instruction at http://www.forum.it-berater.org/index.php?topic=14.0

    Code:
    %DISPATCH_METHOD         = 1
    %DISPATCH_PROPERTYGET    = 2
    %DISPATCH_PROPERTYPUT    = 4
    %DISPATCH_PROPERTYPUTREF = 8
    
    ' ********************************************************************************************
    ' EXCEPINFO structure
    ' ********************************************************************************************
    TYPE EXCEPINFO
       wCode AS WORD               ' An error code describing the error.
       wReserved AS WORD           ' Reserved
       bstrSource AS DWORD         ' Source of the exception.
       bstrDescription AS DWORD    ' Textual description of the error.
       bstrHelpFile AS DWORD       ' Help file path.
       dwHelpContext AS DWORD      ' Help context ID.
       pvReserved AS DWORD         ' Reserved.
       pfnDeferredFillIn AS DWORD  ' Pointer to function that fills in Help and description info.
       scode AS DWORD              ' An error code describing the error.
    END TYPE
    ' ********************************************************************************************
    
    ' ********************************************************************************************
    ' Helper function to calculate the VTable address.
    ' ********************************************************************************************
    FUNCTION TB_VTableAddress (BYVAL pthis AS DWORD, BYVAL dwOffset AS DWORD) AS DWORD
       LOCAL ppthis AS DWORD PTR
       LOCAL pvtbl AS DWORD PTR
       LOCAL ppmethod AS DWORD PTR
       ppthis = pthis
       pvtbl = @ppthis
       ppmethod = pvtbl + dwOffset
       FUNCTION = @ppmethod
    END FUNCTION
    ' ********************************************************************************************
    
    ' ********************************************************************************************
    ' Maps a single member to a corresponding DispID, which can be used on subsequent calls to 
    ' IDispatch_Invoke.
    ' Parameters:
    ' riid
    '   Reserved for future use. Must be IID_NULL.
    ' strName
    '   Name to be mapped.
    ' rgDispId
    '   Retrieved DispID value.
    ' Return Value:
    '   The return value obtained from the returned HRESULT is one of the following:
    '   %S_OK                Success
    '   %E_OUTOFMEMORY       Out of memory
    '   %DISP_E_UNKNOWNNAME  One or more of the names were not known. The returned array of DISPIDs
    '                        contains DISPID_UNKNOWN for each entry that corresponds to an unknown name.
    '   %DISP_E_UNKNOWNLCID  The locale identifier (LCID) was not recognized.
    ' ********************************************************************************************
    DECLARE FUNCTION Proto_IDispatch_GetIDOfName (BYVAL pthis AS DWORD, BYREF riid AS GUID, BYref rgszNames AS string, BYVAL cNames AS DWORD, BYVAL lcid AS DWORD, BYref rgdispid AS long) AS DWORD
    FUNCTION IDispatch_GetIDOfName (BYVAL pthis AS DWORD, BYref strName AS string, BYref rgdispid AS long) AS DWORD
       LOCAL HRESULT AS DWORD
       LOCAL pmethod AS DWORD
       local riid as guid
       if pthis = 0 then exit function
       pmethod = TB_VTableAddress (pthis, 20)
       CALL DWORD pmethod USING Proto_IDispatch_GetIDOfName (pthis, riid, strName, 1, 0, rgdispid) TO HRESULT
       FUNCTION = HRESULT
    END FUNCTION
    ' ********************************************************************************************
    
    ' ********************************************************************************************
    ' Provides access to properties and methods exposed by an object. The dispatch function DispInvoke
    ' provides a standard implementation of IDispatch_Invoke.
    ' Parameters:
    ' dispIdMember
    '   Identifies the member. Use GetIDsOfNames or the object's documentation to obtain the dispatch identifier.
    ' riid
    '    Reserved for future use. Must be IID_NULL.
    ' lcid
    '   The locale context in which to interpret arguments. The lcid is used by the GetIDsOfNames
    '   function, and is also passed to IDispatch_Invoke to allow the object to interpret its
    '   arguments specific to a locale.
    '   Applications that do not support multiple national languages can ignore this parameter.
    ' wFlags
    '   Flags describing the context of the Invoke call, include:
    '     %DISPATCH_METHOD
    '       The member is invoked as a method. If a property has the same name, both this and the
    '       %DISPATCH_PROPERTYGET flag may be set.
    '     %DISPATCH_PROPERTYGET
    '       The member is retrieved as a property or data member.
    '     %DISPATCH_PROPERTYPUT
    '       The member is changed as a property or data member.
    '     %DISPATCH_PROPERTYPUTREF
    '       The member is changed by a reference assignment, rather than a value assignment. This
    '       flag is valid only when the property accepts a reference to an object.
    ' pDispParams
    '   Pointer to a structure containing an array of arguments, an array of argument DISPIDs for
    '   named arguments, and counts for the number of elements in the arrays.
    ' pVarResult
    '   Pointer to the location where the result is to be stored, or NULL if the caller expects no
    '   result. This argument is ignored if DISPATCH_PROPERTYPUT or DISPATCH_PROPERTYPUTREF is specified.
    ' pExcepInfo
    '   Pointer to a structure that contains exception information. This structure should be filled
    '   in if DISP_E_EXCEPTION is returned. Can be NULL.
    ' puArgErr
    '   The index within rgvarg of the first argument that has an error. Arguments are stored in
    '   pDispParams->rgvarg in reverse order, so the first argument is the one with the highest index
    '   in the array. This parameter is returned only when the resulting return value is
    '   %DISP_E_TYPEMISMATCH or %DISP_E_PARAMNOTFOUND. This argument can be set to null.
    ' Return Value:
    '   The return value obtained from the returned HRESULT is one of the following:
    '   %S_OK                     Success
    '   %DISP_E_BADPARAMCOUNT     The number of elements provided to DISPPARAMS is different from the
    '                             number of arguments accepted by the method or property.
    '   %DISP_E_BADVARTYPE        One of the arguments in rgvarg is not a valid variant type.
    '   %DISP_E_EXCEPTION         The application needs to raise an exception. In this case, the
    '                             structure passed in pExcepInfo should be filled in.
    '   %DISP_E_MEMBERNOTFOUND    The requested member does not exist, or the call to Invoke tried to
    '                             set the value of a read-only property.
    '   %DISP_E_NONAMEDARGS       This implementation of IDispatch does not support named arguments.
    '   %DISP_E_OVERFLOW          One of the arguments in rgvarg could not be coerced to the specified type.
    '   %DISP_E_PARAMNOTFOUND     One of the parameter DISPIDs does not correspond to a parameter on
    '                             the method. In this case, puArgErr should be set to the first
    '                             argument that contains the error.
    '   %DISP_E_TYPEMISMATCH      One or more of the arguments could not be coerced. The index within
    '                             rgvarg of the first parameter with the incorrect type is returned
    '                             in the puArgErr parameter.
    '   %DISP_E_UNKNOWNINTERFACE  The interface identifier passed in riid is not IID_NULL.
    '   %DISP_E_UNKNOWNLCID       The member being invoked interprets string arguments according to
    '                             the LCID, and the LCID is not recognized. If the LCID is not needed
    '                             to interpret arguments, this error should not be returned.
    '   %DISP_E_PARAMNOTOPTIONAL  A required parameter was omitted.
    ' ********************************************************************************************
    FUNCTION IDispatch_Invoke (BYVAL pthis AS DWORD, BYVAL dispidMember AS LONG, BYREF riid AS GUID, _
    BYVAL lcid AS DWORD, BYVAL wFlags AS WORD, BYREF pdispparams AS DISPPARAMS, BYREF pvarResult AS VARIANT, _
    BYREF pexcepinfo AS EXCEPINFO, BYREF puArgErr AS DWORD) AS DWORD
       LOCAL HRESULT AS DWORD
       LOCAL pmethod AS DWORD
       if pthis = 0 then exit function
       pmethod = TB_VTableAddress (pthis, 24)
       CALL DWORD pmethod USING IDispatch_Invoke (pthis, dispidMember, riid, lcid, wFlags, pdispparams, pvarResult, pexcepinfo, puArgErr) TO HRESULT
       FUNCTION = HRESULT
    END FUNCTION
    ' ********************************************************************************************
    
    ' ********************************************************************************************
    ' CallByName
    ' ********************************************************************************************
    function TB_CallByName ( _ 
        BYVAL pthis AS DWORD, _                                    ' *IDispatch
        BYVAL vNameOrId AS VARIANT, _                              ' Name or identifier
        byval callType as long, _                                  ' Call type
        byref vParams() as VARIANT, _                              ' Array of variants
        byref vResult as variant, _                                ' Variant result
        byref pex as EXCEPINFO _                                   ' EXCEPINFO
        ) EXPORT AS LONG                                           ' Error code
    
        dim dw_puArgErr AS DWORD, DISPID_PROPERTYPUT AS LONG, IID_NULL AS GUID
        dim vArgs(0) AS VARIANT, udt_DispParams AS DISPPARAMS
        dim strName as string, DispID as long, nParams as long, i as long, idx as long
    
        ' Check for null pointer
        if pthis = 0 then function = -1 : exit function
    
        ' Get the DispID
        if variantvt(vNameOrId) = %VT_BSTR then
           strName = ucode$(variant$(vNameOrId))
           IDispatch_GetIDOfName pthis, strName, DispID
        else
           DispID = variant#(vNameOrId)
        end if
    
        ' Copy the array in reversed order
        if varptr(vParams()) then
           nParams = ubound(vParams) - lbound (vParams) + 1
           if nParams > 0 then
              redim vArgs(nParams - 1)
              idx = nParams - 1
              for i = Lbound(vParams) to Ubound(vParams)
                 if variantvt(vParams(i)) = %VT_EMPTY then
                    vArgs(idx) = error %DISP_E_PARAMNOTFOUND
                 else
                    vArgs(idx) = vParams(i)
                 end if
                 DECR idx
                 if idx < 0 then exit for
              next
           end if
       end if
    
       if CallType = 4 or CallType = 8 then  ' %DISPATCH_PROPERTYPUT and %DISPATCH_PROPERTYPUTREF
          DISPID_PROPERTYPUT = -3
          udt_DispParams.CountNamed = 1
          udt_DispParams.NamedDispId = VARPTR(DISPID_PROPERTYPUT)
       end if
    
       udt_DispParams.CountArgs = nParams
       if nParams > 0 then udt_DispParams.VariantArgs = varptr(vArgs(0))
    
       function = IDispatch_Invoke(pthis, DispID, IID_NULL, 0, CallType, udt_DispParams, vResult, pex, dw_puArgErr)
    
    END function
    ' ********************************************************************************************

    ------------------




    [This message has been edited by José Roca (edited May 18, 2006).]
    Forum: http://www.jose.it-berater.org/smfforum/index.php

  • #2
    An example of how to use it:

    Code:
    #COMPILE EXE
    #DIM ALL
    #DEBUG ERROR ON
    #INCLUDE "WIN32API.INC"
    #INCLUDE "CallByName.INC"
    
    %adOpenKeyset     = &H00000001
    %adLockOptimistic = &H00000003
    %adCmdText        = &H00000001
    
    ' ********************************************************************************************
    ' Main
    ' ********************************************************************************************
    function pbmain
    
       local oCon as dispatch
       local oRec as dispatch
       local hr as dword
       local pex as EXCEPINFO
       local vResult as VARIANT
       local bstrlen as long
       dim vParams(0) as variant
       
       ' Creates a connection instance
       set oCon = new dispatch in "ADODB.Connection"
       if isfalse isobject(oCon) then goto Terminate
       
       redim vParams(3)  ' Four parameters (0:3) - Empty variants are considered as optional parameters
       vParams(0) = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=f:\ffado\biblio.mdb"  ' <-- change as needed
       hr = TB_CallByName(objptr(oCon), "Open", %DISPATCH_METHOD, vParams(), BYVAL %NULL, BYVAL %NULL)
    
       ' Creates a recordset instance
       set oRec = new dispatch in "ADODB.Recordset"
       if isfalse isobject(oRec) then goto Terminate
       
       ' Opens the recordset
       redim vParams(4)  ' Five parameters (0:4)
       vParams(0) = "SELECT TOP 20 * FROM Authors ORDER BY Author"
       set vParams(1) = oCon  ' This is a dispatch variable, so we have to assign it using SET
       vParams(2) = %adOpenKeyset
       vParams(3) = %adLockOptimistic
       vParams(4) = %adCmdText
       hr = TB_CallByName(objptr(oRec), "Open", %DISPATCH_METHOD, vParams(), BYVAL %NULL, BYVAL %NULL)
    
       do
          hr = TB_CallByName(objptr(oRec), "Eof", %DISPATCH_PROPERTYGET, byval %NULL, vResult, BYVAL %NULL)
          if variant#(vResult) then exit do 
          redim vParams(0)  ' One parameter
          vParams(0) = "Author"
          hr = TB_CallByName(objptr(oRec), "Collect", %DISPATCH_PROPERTYGET, vParams(), vResult, BYVAL %NULL)
          print variant$(vResult)
          ' Fetch the next row
          hr = TB_CallByName(objptr(oRec), "MoveNext", %DISPATCH_METHOD, byval %NULL, BYVAL %NULL, BYVAL %NULL)
       loop
        
       
    Terminate:
    
       ' Close the reordset
       hr = TB_CallByName(objptr(oRec), "Close", %DISPATCH_METHOD, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
       ' Close the connection
       hr = TB_CallByName(objptr(oCon), "Close", %DISPATCH_METHOD, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
    
       ' Cleanup
       set oRec = nothing
       set oCon = nothing
    
       waitkey$
    
    end function
    ' ********************************************************************************************

    ------------------




    [This message has been edited by José Roca (edited July 27, 2004).]
    Forum: http://www.jose.it-berater.org/smfforum/index.php

    Comment


    • #3
      If the return code is %DISP_E_EXCEPTION you can retrieve rich error
      information from EXCEPINFO:

      Code:
          DIM bstrlen AS LONG
          DIM strErrorSource AS STRING
          DIM strErrorDescription AS STRING
      
          IF ISTRUE pex.bstrSource THEN 
             bstrlen = SysStringByteLen(BYVAL pex.bstrSource)
             IF ISTRUE bstrlen THEN strErrorSource = ACODE$(PEEK$(pex.bstrSource, bstrlen))
          END IF
      
          IF ISTRUE pex.bstrDescription THEN 
             bstrlen = SysStringByteLen(BYVAL pex.bstrDescription)
             IF ISTRUE bstrlen THEN strErrorDescription = ACODE$(PEEK$(pex.bstrDescription, bstrlen))
          END IF
      The error number will be contained in pex.scode or pex.wcode, but not in both.
      pex is a variable dimed as EXCEPINFO.

      NOTE: The above ADO example doesn't make use of EXCEPINFO because
      ADO has his own errors collection (an ADO operation can cause several
      errors). However, you can pass a variable dimed as EXCEPINFO to retrieve
      information about the last error reported, but remember that EXCEPINFO
      is only filled when the error code returned is %DISP_E_EXCEPTION.
      ------------------



      [This message has been edited by José Roca (edited July 27, 2004).]
      Forum: http://www.jose.it-berater.org/smfforum/index.php

      Comment


      • #4
        Ciao José,

        I know this is a quite old post but I need an advice.
        I need to have a TB_CallByName in which it is not necessary to pass "callType" parameter but it is automatically detected from the passed "vNameOrId" name/id.
        How to?

        Thanks a lot
        Eros
        thinBasic programming language
        Win10 64bit - 8GB Ram - i7 M620 2.67GHz - NVIDIA Quadro FX1800M 1GB

        Comment


        • #5
          It's not possible to detect the type of call by it's name or identifier. The only thing that you can do is to have several functions, one for Call, another for Get, another for Put and another for PutRef.

          Unless you add a prefix to the name, e.g. "call_method name", "get_methodname", "put_methodname", "putref_methodname" to identify the type of call and then remove it before doing the calls to GetIDsOfNames nd Invoke.
          Forum: http://www.jose.it-berater.org/smfforum/index.php

          Comment


          • #6
            But with your type library you are able.
            I need to do all at runtime because I'm adding to thinBasic interpreter to possibility to interact with COM objects.

            So far I was able to add simple interfaces like vbScript where there are simple methods and properties.
            I'm studying how to manage complex interfaces like Excel.Application

            The following is a thinBasic script already working in next thinBasic version.

            Code:
            uses "Console"
            
            dim sScript as string = "MsgBox( ""This is a script evaluated from MSScriptControl component."" & vbcrlf & ""If you see this messagebox it means COM interface is working."", 64 Or 3 )"
            
            dim oVBS as iDispatch
            
            oVBS = NewCom "MSScriptControl.ScriptControl"
            
            IF isobject(oVBS) Then
            
              oVBS.Language       = "VbScript"
              oVBS.AllowUI         = %TRUE
              oVBS.UseSafeSubset  = %FALSE
            
              printl oVBS.Language       
              printl oVBS.AllowUI         
              printl oVBS.UseSafeSubset  
            
              printl oVBS.Eval(sScript)
            
              oVBS = Nothing
            end if
            
            WaitKey
            
            
            String txt = "This is a beautiful day"
            Dim objReg as iDispatch
            
            objReg = NewCom("vbscript.regexp")
            If IsObject(objReg) then
              objReg.Pattern = "i"
              printl objReg.Replace(txt, "##")
              objReg = nothing
            end if
            
            WaitKey
            
            
            
            dim fso as idispatch
            fso = NewCom("Scripting.FileSystemObject")
            if isObject(fso) then
              if fso.FolderExists("c:\windows") then
                printl "There is a folder named c:\Windows"
              end if
              fso = nothing
            end if
            
            waitkey
            My idea to is use TypeLib to scan interfaces at runtime when needed, collect information about interface members (properties, methods, parameters, ...), parse script code and interact with them.

            I will study your TypeLib browser.

            Thanks a lot
            Eros
            thinBasic programming language
            Win10 64bit - 8GB Ram - i7 M620 2.67GHz - NVIDIA Quadro FX1800M 1GB

            Comment


            • #7
              > But with your type library you are able.

              Yes, but that information can only be found parsing the type library.

              > My idea to is use TypeLib to scan interfaces at runtime when needed, collect information about interface members (properties, methods, parameters, ...), parse script code and interact with them.

              This can be slow with big type liraries such EXCEL.
              Forum: http://www.jose.it-berater.org/smfforum/index.php

              Comment


              • #8
                Yes I know but speed is not an issue for a language that is an interpreter :-) even if it is quite fast
                Important is having simple ways to interact with COM object without the need to have include files or external wrapper libraries.

                Simplicity will be of great advantage for thinBasic users.
                I need to hide all of the complexity and give users a simple dotted notation.

                I've already a thinBasic module (DLL) working on Excel and wrapping some of the most important interfaces (see example below) but what it does is wrapping interfaces/properties/methods and for every COM I need to develop a new module. Impracticable!

                I want something general purpose way working on as many COM types without the need to develop a wrapper for every COM library

                Ciao
                Eros

                Code:
                #MINVERSION 1.9.13.0
                
                Uses "Excel"
                Uses "Console"
                
                Function TBMain() As Long
                  Dim xApp        As  Excel_Application
                  Dim xWorkBook1  As  Excel_Workbook
                  Dim xWorkBook2  As  Excel_Workbook
                  Dim xSheet1     As  Excel_Worksheet
                  Dim xSheet2     As  Excel_Worksheet
                  Dim x, y        As  Long
                
                  '---Create a new Excel Application COM Server instance
                  xApp = New Excel_Application
                
                  '---Get back Excel Version
                  cOut "Excel version is: " + xApp.Version
                
                  '---Set Visible to TRUE so we can see what's going on
                  xApp.Visible = %TRUE       
                
                  '---Create 2 Excel workbooks 
                  xWorkBook1 = xApp.WorkBooks.Add
                  xWorkBook2 = xApp.WorkBooks.Add
                  cOut "Number of open workbooks: " & xApp.WorkBooks.Count
                
                  '---New sheets objects can be created in 2 ways
                  '---Here we just get the activesheet
                  xSheet1 = xWorkBook1.Activesheet
                  '---And here we create a new sheet using Add method
                  xWorkBook1.Worksheets.Add
                  xSheet2 = xWorkBook1.Worksheets(2)
                
                  '---We want activate "Sheet1"
                  '---To be able to select a sheet in a workbook, workbook must be the activa one
                  xWorkbook1.Activate
                  xWorkbook1.Worksheets(2).Select
                    '---It is possible to pass also sheet name instead of sheet index
                    'xWorkbook1.Worksheets("Sheet1").Select
                    '---Or it is possible to use sheet directly (if instantiated) using sheet.activate
                    'xsheet1.Activate
                
                  '---Change Sheet name (here Set and Get of a Sheet Name)
                  xSheet1.Name = "thinBasic Test 1"
                  xSheet2.Name = "thinBasic Test 2"
                  cOut _
                            "In Workbook1 there are " & xWorkBook1.Worksheets.Count & " sheets" & $CRLF & 
                            "Worksheet name of sheet 1 is: " & xSheet1.Name & $CRLF & 
                            "Worksheet name of sheet 2 is: " & xSheet2.Name & $CRLF & 
                            ""
                
                  '---Write some text into Excel sheet
                  cOut "Now we will fill some cells"
                  For y = 1 To 50
                    For x = 1 To 5
                      xSheet1.Cells(y, x).Value = "Cell " & Chr$(x + 64) & Format$(y)
                      xSheet2.Cells(y, x).Value = "Cell " & Chr$(x + 64) & Format$(y)
                    Next
                    x = 6
                    xSheet1.Cells(Y, X) = y + y / 10
                    xSheet2.Cells(Y, X) = y + y / 10
                    x = 7
                    xSheet1.Cells(Y, X) = Format$(Rnd(-1000,1000), "$#,.00")
                    xSheet2.Cells(Y, X) = Format$(Rnd(-1000,1000), "$#,.00")
                  Next
                
                  '---Read some text back
                  cOut _
                            "Reading back Cell 2,2 of Sheet 1 = " & xSheet1.Cells(2,2).Value & $CRLF & 
                            "Reading back Cell 2,2 of Sheet 2 = " & xSheet1.Cells(2,2).Value & $CRLF & 
                            ""
                
                  'xSheet1.PrintPreview
                
                  '---Tells Excel application to not show alerts (in this case alert about file already exists before saving)
                  xApp.DisplayAlerts = %FALSE
                  '---Save file name
                  xWorkBook1.SaveAs(APP_ScriptFullName & "_1.xlsx")
                  xWorkBook2.SaveAs(APP_ScriptFullName & "_2.xlsx")
                  '---Reset DisplayAlerts
                  xApp.DisplayAlerts = %TRUE
                
                  '---Close Excel Application
                  xApp.Quit                     
                
                  cOut("OK, test done. thinBasic will now close.", 0, %TRUE)
                
                End Function
                
                
                '--------------------------------------------------------------------
                ' Output some message
                '--------------------------------------------------------------------
                Function cOut(ByVal sMessage As String, Optional lLevel As Long, ByVal Wait As Long)
                  PrintL Time$, String$(lLevel * 2, " ") & sMessage
                
                  If Wait = %TRUE Then
                    PrintL "---Press a key to continue---"
                    WaitKey
                  End If
                
                End Function
                thinBasic programming language
                Win10 64bit - 8GB Ram - i7 M620 2.67GHz - NVIDIA Quadro FX1800M 1GB

                Comment

                Working...
                X