VBA: Cdecl Thunk

CdeclCallback.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CdeclCallback"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
          Source As Any, _
    ByVal Length As Long)

Private Declare Function FlushInstructionCache Lib "kernel32" ( _
    ByVal hProcess As Long, _
    ByVal lpBaseAddress As Long, _
    ByVal dwSize As Long) _
As BOOL

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) _
As Long

Private Declare Function VirtualFree Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long) _
As BOOL

' PAGE_EXECUTE
' PAGE_WRITE
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&

Private Const MEM_COMMIT    As Long = &H1000&
Private Const MEM_RELEASE   As Long = &H8000&

Private Const CODE_SIZE     As Long = 256

Private mBase   As Long ' base address
Private mFreed  As Long ' next freed

Public Sub Initialize(ByVal Count As Long)
    mBase = Platform.Invoke(VirtualAlloc(SYSNULL, Count * CODE_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE))
    mFreed = mBase
End Sub

Public Function Register(ByVal StdcallProc As Long, ByVal DWORDArgumentCount As Long) As Long

    Dim i           As Long
    Dim p           As Long
    Dim lEspDisp8   As Long ' 8 bit displacement (max 127: 32 DWORDs)

    ' ret, arg1, arg2, arg3...
    If DWORDArgumentCount > 32 Then Call Err.Raise(5)
    
    ' emit x86 code (consider pairing)
    
    ' mov  edx, StdcallProc ; (u)
    '
    ' mov  e?x, [esp+X]         ; (v) x N
    ' push e?x                  ; (u) x N
    '
    ' call edx                  ; (v)
    ' ret                       ; (u)
    
    p = mFreed
    
    ' retaddr, argN, argN-1, argN-2, ..., , arg1
    lEspDisp8 = 4 * DWORDArgumentCount

    Call MoveMemory(p, &HBA, 1) ' mov edx, immediate
    Call MoveMemory(p + 1, StdcallProc, 4)  ' addr
    p = p + 5

    ' eax/ecx
    For i = 1 To DWORDArgumentCount
            
        If i Mod 2 Then
        
            ' eax
            Call MoveMemory(p, &H8B, 1)             ' mov r32, r/m32
            Call MoveMemory(p + 1, &H44, 1)         ' ModR/M: 01 (disp8[r]), 000 (eax), 100 (SIB)
            Call MoveMemory(p + 2, &H24, 1)         ' SIB: 00 (*1), 100 (none), 100 (esp)
            Call MoveMemory(p + 3, lEspDisp8, 1)    ' disp8
            
            Call MoveMemory(p + 4, &H50, 1)         ' push eax
        
        Else
        
            ' ecx
            Call MoveMemory(p, &H8B, 1)             ' mov r32, r/m32
            Call MoveMemory(p + 1, &H4C, 1)         ' ModR/M: 01 (disp8[r]), 001 (ecx), 100 (SIB)
            Call MoveMemory(p + 2, &H24, 1)         ' SIB: 00 (*1), 100 (none), 100 (esp)
            Call MoveMemory(p + 3, lEspDisp8, 1)    ' disp8
            
            Call MoveMemory(p + 4, &H51, 1)         ' push ecx
        
        End If
    
        p = p + 5
    
    Next

    Call MoveMemory(p, &HFF, 1)     ' opcode extension group 5
    Call MoveMemory(p + 1, &HD2, 1) ' ModR/M: 11, 010 (call near), 010 (edx)
    p = p + 2

    Call MoveMemory(p, &HC3, 1) ' ret (near)
    p = p + 1

    ' commit
    Call Platform.Invoke(FlushInstructionCache(GetCurrentProcess(), mFreed, p - mFreed))

    Register = mFreed
    
    mFreed = mFreed + CODE_SIZE

End Function
'
'Public Property Get Handle() As Long
'    Handle = mBase
'End Property

Private Sub Class_Terminate()
    If mBase Then
        Call VirtualFree(mBase, 0, MEM_RELEASE)
    End If
End Sub

CdeclInvoker.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CdeclInvoker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function LoadLibraryA Lib "kernel32" ( _
    ByVal lpFileName As String) _
As Long
Private Declare Function LoadLibraryW Lib "kernel32" ( _
    ByVal lpFileName As Long) _
As Long

Private Declare Function FreeLibrary Lib "kernel32" ( _
    ByVal hModule As Long) _
As BOOL

Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As Long, _
    ByVal lpProcName As String) _
As Long

' EnumerateLoadedModules
' EnumThreadWindows
' EnumResourceTypes

Private Declare Function Invoker12 Lib "kernel32" Alias "EnumResourceTypesA" ( _
    ByVal Reserved As Long, _
    ByVal lpCallback As Long, _
          lParam As Any) _
As Long

'Private Declare Function Invoker8 Lib "user32" Alias "EnumWindows" ( _
'    ByVal lpCallback As Long, _
'          lParam As Any) _
'As Long

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
          Source As Any, _
    ByVal Length As Long)

Private Declare Function FlushInstructionCache Lib "kernel32" ( _
    ByVal hProcess As Long, _
    ByVal lpBaseAddress As Long, _
    ByVal dwSize As Long) _
As BOOL

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) _
As Long

Private Declare Function VirtualFree Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long) _
As BOOL

' PAGE_EXECUTE
' PAGE_WRITE
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&

Private Const MEM_COMMIT    As Long = &H1000&
Private Const MEM_RELEASE   As Long = &H8000&

Private Const CODE_SIZE     As Long = 256

Private mModule As Long
Private mBase   As Long ' base address
Private mProcCache As Collection

Public Sub Initialize(ByRef Library As String)
    Dim i As Long
        
    If Platform.IsNT Then
        mModule = Platform.Invoke(LoadLibraryW(StrPtr(Library)))
    Else
        mModule = Platform.Invoke(LoadLibraryA(Library))
    End If

    mBase = Platform.Invoke(VirtualAlloc(SYSNULL, 31 * CODE_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE))

    For i = 0 To 30
        Call GenDriver(mBase + i * CODE_SIZE, i)
    Next

End Sub

Public Function Invoke(ByRef CdeclProcName As String, ParamArray DWORDArguments() As Variant) As Long

    Dim lArgs() As Long ' retval, addr, arg1, arg2, ...
    Dim lCount As Long
    Dim i As Long
    Dim lProcAddr   As Long
    
    ' resolve address
    On Error Resume Next
    lProcAddr = mProcCache(CdeclProcName)
    If Err.Number Then
        On Error GoTo 0
        lProcAddr = Platform.Invoke(GetProcAddress(mModule, CdeclProcName))
        Call mProcCache.Add(lProcAddr, CdeclProcName)
    End If
    On Error GoTo 0
    
    ' assume LBound(DWORDArguments) = 0
    
    lCount = UBound(DWORDArguments) + 1

    If lCount > 30 Then Call Err.Raise(5)
    
    ReDim lArgs(0 To lCount + 2)
    
    lArgs(0) = 0
    lArgs(1) = lProcAddr
    
    For i = 0 To lCount - 1
        lArgs(i + 2) = CLng(DWORDArguments(i))
    Next

    ' invoke
    Call Invoker12(SYSNULL, mBase + lCount * CODE_SIZE, lArgs(0))
    
    Invoke = lArgs(0)
End Function

Private Sub GenDriver(ByVal Base As Long, ByVal DWORDArgumentCount As Long)

    Dim p   As Long
    Dim i   As Long

    ' make ENUMRESTYPEPROC style driver

'    struct DRIVER_PARAM {
'        long retval;
'        FN   func;
'        long argv[...];
'    };
'    BOOL __stdcall driver(HWND unused, LPTSTR unused2, DRIVER_PARAM *param) {
'        param->retval = param->func(param->argv[0], ...);
'        return FALSE;
'    }

    If DWORDArgumentCount > 30 Then Call Err.Raise(5)

    ' emit x86 code (consider pairing)
    
    ' push esi              ; (u)
    ' mov  esi, [esp+16]    ; (v) esi = param
    ' mov  edx, [esi+4]     ; (u) edx = param->func
    '
    ' mov  e?x, [esi+X]     ; (v) x N
    ' push e?x              ; (u) x N
    '
    ' call edx              ; (v)
    ' add  esp, X           ; (u) remove arguments from stack
    ' mov  [esi], eax       ; (v) param->retval = eax
    ' xor  eax, eax         ; (u) return 0
    ' pop  esi              ; (v)
    ' ret  12               ; (u)

    p = Base

    Call MoveMemory(p, &H56, 1) ' push esi
    p = p + 1

    Call MoveMemory(p, &H8B, 1)     ' mov r32, r/m32
    Call MoveMemory(p + 1, &H74, 1) ' ModR/M: 01 (disp8[r]), 110 (esi), 100 (SIB)
    Call MoveMemory(p + 2, &H24, 1) ' SIB: 00 (*1), 100 (none), 100 (esp)
    Call MoveMemory(p + 3, 16, 1)   ' disp8: 16 (3rd argument)
    p = p + 4
    
    Call MoveMemory(p, &H8B, 1)     ' mov r32, r/m32
    Call MoveMemory(p + 1, &H56, 1) ' ModR/M: 01 (disp8[r]), 010 (edx), 110 (esi)
    Call MoveMemory(p + 2, 4, 1)    ' disp8: 4
    p = p + 3
    
    ' esi+8,12,16...
    For i = DWORDArgumentCount - 1 To 0 Step -1
        
        If i Mod 2 Then
        
            ' eax
            Call MoveMemory(p, &H8B, 1)             ' mov r32, r/m32
            Call MoveMemory(p + 1, &H46, 1)         ' ModR/M: 01 (disp8[r]), 000 (eax), 110 (esi)
            Call MoveMemory(p + 2, i * 4 + 8, 1)    ' disp8
            
            Call MoveMemory(p + 3, &H50, 1)         ' push eax
        
        Else
        
            ' ecx
            Call MoveMemory(p, &H8B, 1)             ' mov r32, r/m32
            Call MoveMemory(p + 1, &H4E, 1)         ' ModR/M: 01 (disp8[r]), 001 (ecx), 110 (esi)
            Call MoveMemory(p + 2, i * 4 + 8, 1)    ' disp8
            
            Call MoveMemory(p + 3, &H51, 1)         ' push ecx
        
        End If
    
        p = p + 4

    Next
    
    Call MoveMemory(p, &HFF, 1)     ' opcode extension group 5
    Call MoveMemory(p + 1, &HD2, 1) ' ModR/M: 11, 010 (call near), 010 (edx)
    p = p + 2

    Call MoveMemory(p, &H83, 1)                         ' opcode extension group 1 (r/m32, imm8)
    Call MoveMemory(p + 1, &HC4, 1)                     ' ModR/M: 11, 000 (add), 100 (esp)
    Call MoveMemory(p + 2, DWORDArgumentCount * 4, 1)   ' imm8
    p = p + 3

    ' param->retval = eax
    Call MoveMemory(p, &H89, 1)     ' mov r/m32, r32
    Call MoveMemory(p + 1, &H6, 1)  ' ModR/M: 00 ([r]), 000 (eax), 110 (esi)
    p = p + 2
    
    ' return 0
    Call MoveMemory(p, &H33, 1)     ' xor r32, r/m32
    Call MoveMemory(p + 1, &HC0, 1) ' ModR/M: 11 (r), 000 (eax), 000 (eax)
    p = p + 2
    
    Call MoveMemory(p, &H5E, 1)     ' pop esi
    p = p + 1

    Call MoveMemory(p, &HC2, 1)     ' ret imm16 (near)
    Call MoveMemory(p + 1, 12, 2)   ' imm16
    p = p + 3

    ' commit
    Call Platform.Invoke(FlushInstructionCache(GetCurrentProcess(), Base, p - Base))

End Sub

Private Sub Class_Initialize()
    Set mProcCache = New Collection
End Sub

Private Sub Class_Terminate()
    If mBase Then
        Call VirtualFree(mBase, 0, MEM_RELEASE)
    End If
    If mModule Then
        Call FreeLibrary(mModule)
    End If
End Sub

Out of interest, what does this do? It comes high up in the search results for "Calling __cdecl from VBA", is that its purpose? I can't work out exactly what's going on, not least of all because Platform doesn't seem to be defined anywhere.

Any hints would be fab, I'm intrigued now!

@Greedquest

Thank you for your comment.

Young me want to call Cabinet API from Visual Basic 5 for file compression.
(Now xz/7z are available, but in that time Microsoft CAB was the most efficient compression format.)
https://docs.microsoft.com/en-us/windows/win32/devnotes/cabinet-api-functions

Unfortunately, Cabinet APIs are not STDCALL calling convension, so I cannot use declare statement.
and what is worse, my manager do not accept additional dependencies ― includes native dll, C thunks, and type libraries.

I've got to go with the last resort. I implemented cdecl calling convention thunks in PURE VISUAL BASIC!

Platform class is just helper, no magics in there.
Platform.Invoke converts from win32 error code via GetLastError() to HRESULT and throw COM Exception with Err.Raise.