[VB6] - Calling functions by pointer.

[The trick]

ACTUAL VERSION IN 9 POST
Exploring the function VBA6 figured out a way to call functions the pointer.
It's simple. Declare a function prototype (void function), where the first argument will be further transferred to the function address. Next, do a patch, so he tossed to us at the address specified in the first parameter. Thus it is possible to call functions in the standard modules, class modules, forms, API-functions (eg obtained through LoadLibrary and GetProcAddress).* One note, run the project through Ctrl + F5. And working in the IDE and compiled form.
For "patching" the prototype I made a separate module:

Option Explicit

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Sub EbGetExecutingProj Lib "vba6" (hProject As Long)
Private Declare Function TipGetFunctionId Lib "vba6" (ByVal hProj As Long, ByVal bstrName As Long, ByRef bstrId As Long) As Long
Private Declare Function TipGetLpfnOfFunctionId Lib "vba6" (ByVal hProject As Long, ByVal bstrId As Long, ByRef lpAddress As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal lpbstr As Long)

Private Const PAGE_EXECUTE_READWRITE = &H40

' Вспомогательные функции
Public Sub PatchFunc(FuncName As String, ByVal Addr As Long)
    Dim lpAddr As Long, hProj As Long, sId As Long, InIDE As Boolean

    Debug.Assert MakeTrue(InIDE)

    ' Получаем адрес функции
    If InIDE Then
        EbGetExecutingProj hProj
        TipGetFunctionId hProj, StrPtr(FuncName), sId
        TipGetLpfnOfFunctionId hProj, sId, lpAddr
        SysFreeString sId
    Else
        lpAddr = GetAddr(Addr)
        VirtualProtect lpAddr, 8, PAGE_EXECUTE_READWRITE, 0
    End If

    ' Записываем вставку
    ' Запускать только по Ctrl+F5!!
    ' pop eax
    ' pop ecx
    ' push eax
    ' jmp ecx

    GetMem4 &HFF505958, ByVal lpAddr
    GetMem4 &HE1, ByVal lpAddr + 4
End Sub

Private Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

Example call normal functions in a standard module:

' Пример вызова обычных функции по указателю
Public Sub Main()

    ' Пропатчиваем функции, перед первым вызовом
    PatchFunc "Proto1", AddressOf Proto1
    PatchFunc "Proto2", AddressOf Proto2

    MsgBox Proto1(AddressOf Func1, 1, "Вызов")
    MsgBox Proto1(AddressOf Func2, 2, "По указателю")
    MsgBox Proto1(AddressOf Func3, 3, ";)")

    Call Proto2(AddressOf Sub1)
    Call Proto2(AddressOf Sub2)
End Sub

' Прототип функций
Private Function Proto1(ByVal Addr As Long, ByVal x As Long, y As String) As String
End Function
Private Sub Proto2(ByVal Addr As Long)
End Sub
' Функции
Private Function Func1(ByVal x As Long, y As String) As String
    Func1 = "Func1_" & y
End Function
Private Function Func2(ByVal x As Long, y As String) As String
    Func2 = "Func2_" & y
End Function
Private Function Func3(ByVal x As Long, y As String) As String
    Func3 = "Func3_" & y
End Function
Private Sub Sub1()
    MsgBox "Sub1"
End Sub
Private Sub Sub2()
    MsgBox "Sub2"
End Sub

Example API calls at getting through GetProcAddress:

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long


' Пример вызова WinApi функций по указателю
Public Sub Main()
    Dim hUser As Long, hGDI As Long
    Dim DC As Long

    hUser = LoadLibrary("user32")
    hGDI = LoadLibrary("gdi32")

    PatchFunc "GetDC", AddressOf GetDC
    PatchFunc "ReleaseDC", AddressOf ReleaseDC
    PatchFunc "Ellipse", AddressOf Ellipse

    DC = GetDC(GetProcAddress(hUser, "GetDC"), 0)
    Ellipse GetProcAddress(hGDI, "Ellipse"), DC, 0, 0, 500, 500
    ReleaseDC GetProcAddress(hUser, "ReleaseDC"), 0, DC
End Sub

' Прототип функций
Private Function GetDC(ByVal Addr As Long, ByVal hWnd As Long) As Long
End Function
Private Function ReleaseDC(ByVal Addr As Long, ByVal hWnd As Long, ByVal hdc As Long) As Long
End Function
Private Function Ellipse(ByVal Addr As Long, ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
End Function

Example call class methods on the pointer:
.bas module:

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long

' Пример вызова методов объекта по указателю
Public Sub Main()
    Dim IUnk    As Long
    Dim lpProp  As Long
    Dim lpView  As Long
    Dim Obj1    As clsTest
    Dim Obj2    As clsTest
    Dim ret     As Long

    Set Obj1 = New clsTest
    Set Obj2 = New clsTest
    
    GetMem4 ByVal ObjPtr(Obj1), IUnk
    GetMem4 ByVal IUnk + &H1C, lpProp
    GetMem4 ByVal IUnk + &H20, lpView
    
    PatchFunc "clsTest_PropLet", AddressOf clsTest_PropLet
    PatchFunc "clsTest_View", AddressOf clsTest_View
    
    clsTest_PropLet lpProp, Obj1, 1234
    clsTest_PropLet lpProp, Obj2, 9876
    
    clsTest_View lpView, Obj1, ret
    Debug.Print ret
    clsTest_View lpView, Obj2, ret
    Debug.Print ret
End Sub

' Прототип функций
Private Function clsTest_PropLet(ByVal Addr As Long, ByVal Obj As clsTest, ByVal Value As Long) As Long
End Function
Private Function clsTest_View(ByVal Addr As Long, ByVal Obj As clsTest, ret As Long) As Long
End Function

Class module:

Option Explicit

Dim mValue As Long

Public Property Let Prop(ByVal Value As Long)
    mValue = Value
End Property
Public Function View() As Long
    View = MsgBox(mValue, vbYesNoCancel)
End Function

Good luck!

CallPointer.zip

[LaVolpe]

Another way, rather simple and less limitations, would be the use of the API DispCallFunc.

[The trick]

DispCallFunc much slower. DispCallFunc can be used for other calling conventions (CC_CDECL etc.). DispCallFunc also preferable to use to call methods on a COM object. For example:

Private Function IAccessibleGet_accState(obj As IUnknown, VarID As Variant) As Variant
    Dim types() As Integer, param() As Long
    ReDim types(1): ReDim param(1)
    types(0) = vbVariant: types(1) = vbLong
    param(0) = VarPtr(VarID): param(1) = VarPtr(IAccessibleGet_accState): IAccessibleGet_accState = param(1)
    Call DispCallFunc(obj, 56, CC_STDCALL, vbLong, 2, types(0), param(0), 0)
End Function

[LaVolpe]

True, but DispCallFunc can be wrapped in a generic function and that function can be called for both GetProcAddress pointers and COM objects, with variable parameters, and without having to create prototypes or patching VTables. Just another way to skin a cat.

[The trick]

Here too so it is possible. I normally use DispCallFunc when you do not want to add modules (to make all of the code in the class). Such as registration of libraries, etc. The main plus - is to support different calling conventions, but the code can also be slightly modified to support other agreements.

[Schmidt]

On another note...

All these methods (as the above trick) which depend on vba6.dll -
are not usable within your Applications "in the wild"...

They will work only on machines where the VB6-IDE is installed
(and are therefore useful for IDE-plugins and stuff) - but not much
else, since - IIRC - vba6.dll is not listed in redist.txt...

Edit: Overlooked the InIde-check, so all fine for the above code...

Olaf

[LaVolpe]

Olaf, haven't reviewed his other threads, but in this thread vba6.dll appears to be only called if project is in the IDE.

[Schmidt]

Olaf, haven't reviewed his other threads, but in this thread vba6.dll appears to be only called if project is in the IDE.

Oops - right you are - sorry @ Кривоус.

Olaf

[The trick]

I've modified this module (now it is yet smaller):

Option Explicit

Private Declare Function GetMem4 Lib "msvbvm60" ( _
                         ByRef src As Any, _
                         ByRef dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" ( _
                         ByVal lpAddress As Long, _
                         ByVal dwSize As Long, _
                         ByVal flNewProtect As Long, _
                         ByRef lpflOldProtect As Long) As Long
 
Private Const PAGE_EXECUTE_READWRITE = &H40

' // Helpers functions
Public Sub PatchFunc(ByVal Addr As Long)
    Dim InIDE As Boolean
 
    Debug.Assert MakeTrue(InIDE)
 
    If InIDE Then
        GetMem4 ByVal Addr + &H16, Addr
    Else
        VirtualProtect Addr, 8, PAGE_EXECUTE_READWRITE, 0
    End If

    GetMem4 &HFF505958, ByVal Addr
    GetMem4 &HE1, ByVal Addr + 4
End Sub
 
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

Also i've added the new example that show the analog of the c++ function - qsort, where the comparing parameter is the user function:

Option Explicit

Private Type Vector2D
    posX As Single
    posY As Single
End Type

Private Declare Sub memcpy Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef Destination As Any, _
                    ByRef Source As Any, _
                    ByVal Length As Long)
                    
' // Buffer for exchanging
Dim buffer()    As Byte
Dim isInit      As Boolean

' // Calling of the standard functions using the pointers
Public Sub Main()
    Dim lngArray()  As Long
    Dim index       As Long
    
    ' // We're testing the function that sorts the long-array
    ReDim lngArray(99)
    
    For index = 0 To UBound(lngArray)
        lngArray(index) = Rnd * 100
    Next
    
    ' // Magic of the function pointers
    QuickSort VarPtr(lngArray(0)), UBound(lngArray) + 1, Len(lngArray(0)), AddressOf ComparatorLong
    
    ' // Now we're testing the function that sorts the string-array
    Dim strArray()  As String
    
    ReDim strArray(5)
    
    strArray(0) = "Calling"
    strArray(1) = "of the standard functions"
    strArray(2) = "using the pointers"
    strArray(3) = "on VB6"
    strArray(4) = "by The trick"
    strArray(5) = "2015"
    
    ' // We're calling same function using the magic of pointers
    QuickSort VarPtr(strArray(0)), UBound(strArray) + 1, 4, AddressOf ComparatorString
    
    ' // Now we're testing the function that sorts the UDT-array (2D-vectors)
    ' // For example we'll sorting the array by vector length
    Dim vecArray() As Vector2D
    
    ReDim vecArray(99)
    
    For index = 0 To UBound(vecArray)
        vecArray(index).posX = Rnd * 10
        vecArray(index).posY = Rnd * 10
    Next
    
    ' // We're calling same function for the sorting of the UDT-array
    QuickSort VarPtr(vecArray(0)), UBound(vecArray) + 1, LenB(vecArray(0)), AddressOf ComparatorVector2D
    
    ' // Test length
    For index = 0 To UBound(vecArray)
        Debug.Print Sqr(vecArray(index).posX ^ 2 + vecArray(index).posY ^ 2)
    Next
    
End Sub

' // This callback function which sorts two long values
Public Function ComparatorLong( _
                ByRef lItem1 As Long, _
                ByRef lItem2 As Long) As Long
    ComparatorLong = Sgn(lItem1 - lItem2)
End Function

' // This callback function which sorts two string values
Public Function ComparatorString( _
                ByRef lItem1 As String, _
                ByRef lItem2 As String) As Long
    ComparatorString = StrComp(lItem1, lItem2, vbTextCompare)
End Function

' // This callback function which sorts two 2D-vectors values by length
Public Function ComparatorVector2D( _
                ByRef lItem1 As Vector2D, _
                ByRef lItem2 As Vector2D) As Long
    ' // Optimize sqr
    ComparatorVector2D = Sgn((lItem1.posX * lItem1.posX + lItem1.posY * lItem1.posY) - _
                             (lItem2.posX * lItem2.posX + lItem2.posY * lItem2.posY))
End Function

' // Quick-sort using the callback function for a comparing
' // This function uses callback function (lpfnComparator)
Public Sub QuickSort( _
           ByVal lpFirstPtr As Long, _
           ByVal lNumOfItems As Long, _
           ByVal lSizeElement As Long, _
           ByVal lpfnComparator As Long)
           
    Dim lpI     As Long
    Dim lpJ     As Long
    Dim lpM     As Long
    Dim lpLast  As Long
    
    If Not isInit Then
        ' // Initialize patching and buffer for exchanging
        ReDim buffer(lSizeElement - 1)
        PatchFunc AddressOf MainComparator
        isInit = True
        
    End If
    
    lpLast = lpFirstPtr + (lNumOfItems - 1) * lSizeElement
    lpI = lpFirstPtr
    lpJ = lpLast
    lpM = lpFirstPtr + ((lNumOfItems - 1) \ 2) * lSizeElement

    Do Until lpI > lpJ
        
        ' // Call function that being passed into the lpfnComparator parameter
        Do While MainComparator(lpfnComparator, lpI, lpM) = -1
            lpI = lpI + lSizeElement
        Loop
        
        ' // Call function that being passed into the lpfnComparator parameter
        Do While MainComparator(lpfnComparator, lpJ, lpM) = 1
            lpJ = lpJ - lSizeElement
        Loop
        
        ' // Exchanging
        If (lpI <= lpJ) Then
            
            If lpI = lpM Then
                lpM = lpJ
            ElseIf lpJ = lpM Then
                lpM = lpI
            End If
            
            If lSizeElement > UBound(buffer) + 1 Then
                ReDim buffer(lSizeElement - 1)
            End If
            
            memcpy buffer(0), ByVal lpI, lSizeElement
            memcpy ByVal lpI, ByVal lpJ, lSizeElement
            memcpy ByVal lpJ, buffer(0), lSizeElement
  
            lpI = lpI + lSizeElement
            lpJ = lpJ - lSizeElement
            
        End If
        
    Loop

    If lpFirstPtr < lpJ Then
        QuickSort lpFirstPtr, (lpJ - lpFirstPtr) \ lSizeElement + 1, lSizeElement, lpfnComparator
    End If
    
    If lpI < lpLast Then
        QuickSort lpI, (lpLast - lpI) \ lSizeElement + 1, lSizeElement, lpfnComparator
    End If
    
End Sub

' // Prototype for comparator function
' // If lpItem1 > lpItem2 then function return 1
' // If lpItem1 = lpItem2 then function return 0
' // If lpItem1 < lpItem2 then function return -1
Public Function MainComparator( _
                ByVal lpAddressOfFunction As Long, _
                ByVal lpItem1 As Long, _
                ByVal lpItem2 As Long) As Long
End Function

Download.

[wqweto]

Insetad of keeping track with isInit can you call PatchFunc in MainComparator like this

Public Function MainComparator( _
                ByVal lpAddressOfFunction As Long, _
                ByVal lpItem1 As Long, _
                ByVal lpItem2 As Long) As Long
    PatchFunc AddressOf MainComparator
    MainComparator = MainComparator(lpAddressOfFunction, lpItem1, lpItem2)
End Function

... for some wicked self-modifying code :-))

cheers,
</wqw>

[georgekar]

If we have a function in an object, then is it possible to call that function and use the objects variables to hold total or other values from more than one call to function, to this object?

[The trick]

If we have a function in an object, then is it possible to call that function and use the objects variables to hold total or other values from more than one call to function, to this object?

Do you saw the TrickCallPointerClass example? This example shows how can you call the methods of the objects by the pointer. You should pass the object as the second parameter, and the return value (if need) is passed in the last parameters as the pointer (ByRef).

[The trick]

Insetad of keeping track with isInit can you call PatchFunc in MainComparator like this

Public Function MainComparator( _
                ByVal lpAddressOfFunction As Long, _
                ByVal lpItem1 As Long, _
                ByVal lpItem2 As Long) As Long
    PatchFunc AddressOf MainComparator
    MainComparator = MainComparator(lpAddressOfFunction, lpItem1, lpItem2)
End Function

... for some wicked self-modifying code :-))

cheers,
</wqw>

Nice advice. It needs to test it on the compiled file.

[wqweto]

It seems there is a limitation of `AddressOf` operator -- you cannot use it inside a function to get current function address, i.e. `AddressOf MainComparator` cannot be compiled inside `MainComparator` function.

So you have to use a helper function like this

Public Function MainComparator( _
                ByVal lpAddressOfFunction As Long, _
                ByVal lpItem1 As Long, _
                ByVal lpItem2 As Long) As Long
    PatchFunc pvMainComparatorAddr
    MainComparator = MainComparator(lpAddressOfFunction, lpItem1, lpItem2)
End Function

Private Function pvMainComparatorAddr() As Long
    Call memcpy(pvMainComparatorAddr, AddressOf MainComparator, 4)
End Function

The self-modifying part seems to work both in IDE and compiled.

Btw, I would call `MainComparator` something like `DelegateCompare` or similar. Every VB6 developer has a personal implementation of a similar delegator. I'm personally using the exactly same ASM thunk on a lightweight object with number of functions like Call1, Call2, Call3, etc each accepting 1, 2, 3, etc. number of (long) parameters. Popping return address from stack hides the delegator from call-stack too.

This is my delegator initialization function

Private Function pvInitDelegator(This As DelegatorData) As IDelegator
'00401030 59                   pop         ecx
'00401031 58                   pop         eax
'00401032 58                   pop         eax
'00401033 51                   push        ecx
'00401034 FF E0                jmp         eax
'00401036 90                   nop
'00401037 90                   nop
    Dim dwDummy         As Long
    Dim lIdx            As Long

    If m_aDelegatorVtbl(0) = 0 Then
        m_uDelegatorThunk.Code.Thunk(0) = &H51585859
        m_uDelegatorThunk.Code.Thunk(1) = &H9090E0FF
        Call VirtualProtect(m_uDelegatorThunk.Code.Thunk(0), 8, PAGE_EXECUTE_READWRITE, dwDummy)
        m_aDelegatorVtbl(0) = pvAddr(AddressOf pvDelegatorQI)
        m_aDelegatorVtbl(1) = pvAddr(AddressOf pvDelegatorAR)
        m_aDelegatorVtbl(2) = pvAddr(AddressOf pvDelegatorAR)
        For lIdx = 3 To UBound(m_aDelegatorVtbl)
            m_aDelegatorVtbl(lIdx) = VarPtr(m_uDelegatorThunk.Code.Thunk(0))
        Next
    End If
    This.pVTable = VarPtr(m_aDelegatorVtbl(0))
    Call CopyMemory(pvInitDelegator, VarPtr(This), 4)
End Function

This allows me to use comctl subclassing with a single redirection function like this

Private Function pvRedirectComCtlProc( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByVal uIdSubclass As Long, _
            ByVal ThisPtr As Long) As Long
    #If NO_DELEGATOR Then
        m_uComCtlThunk.Code.Thunk(1) = ThisPtr
        m_uComCtlThunk.Code.Thunk(4) = uIdSubclass
        pvRedirectComCtlProc = CallWindowProc(m_uComCtlThunk.pfn, hWnd, wMsg, wParam, lParam)
    #Else
        pvRedirectComCtlProc = m_pDelegator.Call5(uIdSubclass, ThisPtr, hWnd, wMsg, wParam, lParam)
    #End If
End Function

Your code looks much better and will allow me to get rid of the custom typelib and simplify the whole delegation story a lot. Kudos!

cheers,
</wqw>

[Bonnie West]

It seems there is a limitation of `AddressOf` operator -- you cannot use it inside a function to get current function address, i.e. `AddressOf MainComparator` cannot be compiled inside `MainComparator` function.

Yep, that's a known bug. The suggested workaround in the KB article PRB: Recursive Use of AddressOf Operator Fails is qualifying the procedure's name with the module's name. It'll work even if the procedure is Private and thus not shown in the IntelliSense list.