VB6 CDECL

Private Declare Function DispCallFunc Lib "oleaut32.dll" ( _
     ByVal pvInstance As Long, _
     ByVal oVft As Long, _
     ByVal cc As Long, _
     ByVal vtReturn As Integer, _
     ByVal cActuals As Long, _
     ByRef prgvt As Integer, _
     ByRef prgpvarg As Long, _
     ByRef pvargResult As Variant _
) As Long




Private Function CallCDECL(ByVal FuncAddr As Long, ByRef Params() As Variant, ByVal ReturnType As VbVarType) As Variant
    Dim ParamCount As Long
    Dim ParamTypes() As Integer
    Dim ParamPtrs() As Long
    Dim n As Long
   
    ParamCount = UBound(Params) + 1
    If ParamCount > 0 Then
        ReDim ParamTypes(ParamCount - 1)
        ReDim ParamPtrs(ParamCount - 1)
        For n = 0 To ParamCount - 1
            ParamTypes(n) = VarType(Params(n))
            ParamPtrs(n) = VarPtr(Params(n))
        Next n
        DispCallFunc 0, FuncAddr, 1, ReturnType, ParamCount, ParamTypes(0), ParamPtrs(0), CallCDECL
    Else
        DispCallFunc 0, FuncAddr, 1, ReturnType, ParamCount, ByVal 0, ByVal 0&, CallCDECL
    End If
End Function

Private Declare Function CallAsmAddr Lib "user32" Alias "CallWindowProcA" (
    ByVal lpCode As Long, ByVal hwnd As Long,
    ByVal msg As Long, ByVal wParam As Long,
    ByVal lParam As Long
) 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 Long

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


'should be dep safe..
Function CallCdecl(lpfn As Long, ParamArray args()) As Long

    Dim asm() As String
    Dim stub() As Byte
    Dim i As Long
    Dim argSize As Byte
    Dim ret As Long
    Const PAGE_RWX      As Long = &H40
    Const MEM_COMMIT    As Long = &H1000
    Dim asmAddr As Long
    Dim sz As Long
    
    Const depSafe = True
    
    If lpfn = 0 Then Exit Function
    
    'push asm(), "CC"  'enable this to debug asm
    
    'we step through args backwards to preserve intutive ordering
    For i = UBound(args) To 0 Step -1
        If Not IsNumeric(args(i)) Then
            MsgBox "CallCdecl Invalid Parameter #" & i & " TypeName=" & TypeName(args(i))
            Exit Function
        End If
        push asm(), "68 " & lng2Hex(CLng(args(i)))  '68 90807000    PUSH 708090
        argSize = argSize + 4
    Next

    push asm(), "B8 " & lng2Hex(lpfn)        'B8 90807000    MOV EAX,708090
    push asm(), "FF D0"                      'FFD0           CALL EAX
    push asm(), "83 C4 " & Hex(argSize)      '83 C4 XX       add esp, XX     'cleanup args
    push asm(), "C2 10 00"                   'C2 10 00       retn 10h        'cleanup our callwindowproc args
    
    stub() = toBytes(Join(asm, " "))
    
    If Not depSafe Then
        CallCdecl = CallAsm(stub(0), 0, 0, 0, 0)
        Exit Function
    End If
    
    sz = UBound(stub) + 1
    asmAddr = VirtualAlloc(ByVal 0&, sz, MEM_COMMIT, PAGE_RWX)
    
    If asmAddr = 0 Then
        MsgBox "Failed to allocate RWE memory size: " & sz, vbInformation
        Exit Function
    End If
    
    RtlMoveMemory asmAddr, VarPtr(stub(0)), sz
    CallCdecl = CallAsmAddr(asmAddr, 0, 0, 0, 0)
    VirtualFree asmAddr, sz, 0
    
    
End Function