Option Explicit
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Private Declare Function VariantCopy Lib "oleaut32" (pvarDest As Any, pvargSrc As Any) As Long
Private Sub Command1_Click()
Dim lResult As Long
Debug.Print "DispInvoke=" & DispInvoke(Command1, "Name", VbGet Or VbMethod)
Debug.Print "IsError=" & IsError(DispInvoke(Command1, "Index", VbGet Or VbMethod))
Debug.Print "IsEmpty=" & IsEmpty(DispInvoke(Command1, "Move", VbMethod, 1000, 0, 1000, 2000))
Debug.Print "IsEmpty=" & IsEmpty(DispInvoke(Command1, "Left", VbLet, 500))
Debug.Print "DispInvoke=" & DispInvoke(Me, "Test", VbMethod, lResult), "lResult=" & lResult
End Sub
Public Function Test(lResult As Long) As Boolean
lResult = 42
Test = True
End Function
Public Function DispInvoke( _
ByVal pDisp As Object, _
ProcName As Variant, _
ByVal CallType As VbCallType, _
ParamArray Args() As Variant) As Variant
Const DISP_E_MEMBERNOTFOUND As Long = &H80020003
Const DISP_E_PARAMNOTOPTIONAL As Long = &H8002000F
Const DISPID_PROPERTYPUT As Long = -3
Const IDX_GetIDsOfNames As Long = 5
Const IDX_Invoke As Long = 6
Dim IID_NULL(0 To 3) As Long
Dim lDispID As Long
Dim vRevArgs As Variant
Dim lIdx As Long
Dim aParams(0 To 3) As Long
Dim lPropPutDispID As Long
Dim lResultPtr As Long
Dim hResult As Long
If pDisp Is Nothing Then
hResult = DISP_E_PARAMNOTOPTIONAL
GoTo QH
End If
'--- figure out procedure DispID
If IsNumeric(ProcName) Then
lDispID = ProcName
Else
hResult = DispCallByVtbl(ObjPtr(pDisp), IDX_GetIDsOfNames, VarPtr(IID_NULL(0)), VarPtr(StrPtr(ProcName)), 1&, 0&, VarPtr(lDispID))
If hResult < 0 Then
GoTo QH
End If
End If
'--- reverse arguments
If UBound(Args) >= 0 Then
ReDim vRevArgs(0 To UBound(Args) - LBound(Args)) As Variant
For lIdx = 0 To UBound(vRevArgs)
'--- have to keep VT_BYREF so cannot use simple assignment here
Call VariantCopy(vRevArgs(lIdx), Args(UBound(Args) - lIdx))
Next
aParams(0) = VarPtr(vRevArgs(0)) ' .rgPointerToVariantArray
aParams(2) = UBound(vRevArgs) + 1 ' .cArgs
End If
If (CallType And (VbLet Or VbSet)) <> 0 Then
lPropPutDispID = DISPID_PROPERTYPUT
aParams(1) = VarPtr(lPropPutDispID) ' .rgPointerToLongNamedArgs
aParams(3) = 1 ' .cNamedArgs
End If
If (CallType And (VbGet Or VbMethod)) <> 0 Then
lResultPtr = VarPtr(DispInvoke)
End If
hResult = DispCallByVtbl(ObjPtr(pDisp), IDX_Invoke, lDispID, VarPtr(IID_NULL(0)), 0&, CallType, VarPtr(aParams(0)), lResultPtr, 0&, 0&)
'--- take care of subs (some do not accept result pointer)
If hResult = DISP_E_MEMBERNOTFOUND And (CallType And VbMethod) <> 0 Then
hResult = DispCallByVtbl(ObjPtr(pDisp), IDX_Invoke, lDispID, VarPtr(IID_NULL(0)), 0&, CallType, VarPtr(aParams(0)), 0&, 0&, 0&)
End If
QH:
If hResult < 0 Then
IID_NULL(0) = vbError
IID_NULL(2) = hResult
Call VariantCopy(DispInvoke, IID_NULL(0))
End If
End Function
Private Function DispCallByVtbl(ByVal pUnk As Long, ByVal lIndex As Long, ParamArray Args() As Variant) As Variant
Const CC_STDCALL As Long = 4
Dim vParams As Variant
Dim lIdx As Long
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As Long
Dim hResult As Long
vParams = Args
For lIdx = 0 To UBound(vParams)
vType(lIdx) = VarType(vParams(lIdx))
vPtr(lIdx) = VarPtr(vParams(lIdx))
Next
hResult = DispCallFunc(pUnk, lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function