1,488
社区成员




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
Option Explicit
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
Sub Main()
Dim fp As Long
fp = FARPROC(AddressOf Max)
Debug.Print CallWindowProc(fp, 3, 2, 0, 0)
End Sub
Function 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 Function
Function FARPROC(ByVal fp As Long) As Long
FARPROC = fp
End Function
Option Explicit
Private 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 Type
Sub 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 Sub
Function 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 Function
Function FARPROC(ByVal fp As Long) As Long
FARPROC = fp
End Function