Option Explicit



Private Type VariableBuffer

    VariableParameter() As Byte

End Type



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

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 Byte



Public 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 Function



Private 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 Function



Private Sub AddLongToCode(lData As Long)

    CopyMemory m_OpCode(m_opIndex), lData, 4

    m_opIndex = m_opIndex + 4

End Sub



Private Sub AddIntToCode(iData As Integer)

    CopyMemory m_OpCode(m_opIndex), iData, 2

    m_opIndex = m_opIndex + 2

End Sub



Private Sub AddByteToCode(bData As Byte)

    m_OpCode(m_opIndex) = bData

    m_opIndex = m_opIndex + 1

End Sub