如何调用带参数的函数指针

Question

在Supermanking的blog找到了他发的一个用调用外部函数的类，而我现在的应用中不是调用外部函数，而是直接调用模块中的函数，我把他的类稍微改了下，去掉对dll和函数指针的获取那段，如果不带参数，那么可以执行的过，带参数过去的话程序就崩溃了，估计是压栈那段代码，原作者的注释和代码太多，就不贴完了，贴我改过的APIClass代码
Option ExplicitPrivate Type VariableBuffer
    VariableParameter() As Byte
End TypePrivate 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
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)Private m_opIndex As Long
Private m_OpCode() As BytePublic Function ExecuteAPI(LibPath As String, FunctionName As String, ParamArray ParameterArray() As Variant) As Long
'这里是调用外部函数的，太长了，略过
End Function'下面这是调用模块中的函数的
Public Function ExecuteFunc(hProcAddress As Long, ParamArray ParameterArray()) As Long
  Dim X As Long, Y As Long
  Dim LongCount As Long, StringInfo As String, StrByteArray() As VariableBuffer
  Dim StringSize As Long, ByteArray() As Byte, IsHaveParameter As Boolean
  Dim OutputArray() As Long
  StringSize = 0
  ReDim StrByteArray(StringSize)
  '识别函数名称
  IsHaveParameter = CBool(UBound(ParameterArray) <> -1)
  If IsHaveParameter Then
      '初始化函数内存大小
      ReDim OutputArray(UBound(ParameterArray))
 
      '格式化函数参数
      For X = 0 To UBound(ParameterArray)
        If IsNumeric(Trim(ParameterArray(X))) = True Then
            LongCount = CLng(Trim(ParameterArray(X)))
            OutputArray(X) = LongCount
        Else
            StringInfo = Mid(Trim(ParameterArray(X)), 2, Len(ParameterArray(X)) - 3)
            If Len(StringInfo) = 0 Then
              OutputArray(X) = CLng(VarPtr(Null))
            Else
              ReDim Preserve StrByteArray(StringSize)
              ByteArray = StrConv(StringInfo, vbFromUnicode)
              ReDim Preserve StrByteArray(StringSize).VariableParameter(UBound(ByteArray) + 1)
              CopyMemory StrByteArray(StringSize).VariableParameter(0), ByteArray(0), UBound(ByteArray) + 1
              OutputArray(X) = CLng(VarPtr(StrByteArray(StringSize).VariableParameter(0)))
              StringSize = StringSize + 1
            End If
        End If
      Next X
      ReDim m_OpCode(400 + 6 * UBound(OutputArray)) '保留用来写m_OpCode
  End If  If IsHaveParameter = True Then
      '带参数的情况在此执行
      '崩溃在这段代码，估计是GetCodeStart的压栈问题，VB的内部函数接口和DLL的函数接口不知道是不是都是__stdcall的
      ExecuteFunc = CallWindowProc(GetCodeStart(hProcAddress, OutputArray), 0, 1, 2, 3)
  Else
      '不带参数的情况在此执行，这里可以执行成功
      ExecuteFunc = CallWindowProc(hProcAddress, 0, 1, 2, 3)
  End If
End FunctionPrivate Function GetCodeStart(ByVal lngProc As Long, arrParams() As Long) As Long
    Dim lngIndex As Long, lngCodeStart As Long
    lngCodeStart = (VarPtr(m_OpCode(0)) Or &HF) + 1 'GetCodeStart的函数返回值只在这里赋值，m_OpCode是个空的数组，估计这里是函数与参数的内存地址
    m_opIndex = lngCodeStart - VarPtr(m_OpCode(0))
    For lngIndex = 0 To m_opIndex - 1
        m_OpCode(lngIndex) = &HCC
    Next lngIndex
    For lngIndex = UBound(arrParams) To 0 Step -1
      AddByteToCode &H68
      AddLongToCode arrParams(lngIndex)
    Next lngIndex
    AddByteToCode &HE8
    AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4'估计函数和参数的内存地址在这里压栈，对DLL的函数和参数是这样压栈的，但是对内部函数和参数如何压栈？
    AddByteToCode &HC2
    AddByteToCode &H10
    AddByteToCode &H0
    GetCodeStart = lngCodeStart
End FunctionPrivate Sub AddLongToCode(lData As Long)
    CopyMemory m_OpCode(m_opIndex), lData, 4
    m_opIndex = m_opIndex + 4
End SubPrivate Sub AddIntToCode(iData As Integer)
    CopyMemory m_OpCode(m_opIndex), iData, 2
    m_opIndex = m_opIndex + 2
End SubPrivate Sub AddByteToCode(bData As Byte)
    m_OpCode(m_opIndex) = bData
    m_opIndex = m_opIndex + 1
End Sub

Answer 1

内部函数指针调用很简单，只要保证函数和 WindowProc 一致就可以了。
原理可 Google: Visual Basic变态用法之函数指针
Option ExplicitPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongSub Main()
    Dim fp As Long
    fp = FARPROC(AddressOf Max)
    Debug.Print CallWindowProc(fp, 3, 2, 0, 0)
End SubFunction Max(ByVal v1 As Long, ByVal v2 As Long, ByVal Dummy3 As Long, ByVal Dummy4 As Long) As Long
    Max = IIf(v1 > v2, v1, v2)
End FunctionFunction FARPROC(ByVal fp As Long) As Long
    FARPROC = fp
End Function

Answer 2

用 Any 类型的参数传递 UDT，可以包含任意信息
Option ExplicitPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    ByRef lParam As Any) As Long '<-注意 lParam 的类型Type LongArray
    '这里可以定义任意多的成员
    Items() As Long
End TypeSub Main()
    Dim a As LongArray
    Dim fp As Long
    
    ReDim a.Items(4)
    a.Items(0) = 20
    a.Items(1) = 8
    a.Items(2) = 7
    a.Items(3) = 9
    a.Items(4) = 11
    fp = FARPROC(AddressOf Sum)
    Debug.Print CallWindowProc(fp, 0, 0, 0, a)
End SubFunction Sum(ByVal Dummy1 As Long, ByVal Dummy2 As Long, ByVal Dummy3 As Long, Data As LongArray) As Long
    Dim lSum As Long
    Dim i As Long
    For i = LBound(Data.Items) To UBound(Data.Items)
        lSum = lSum + Data.Items(i)
    Next
    Sum = lSum
End FunctionFunction FARPROC(ByVal fp As Long) As Long
    FARPROC = fp
End Function