动态调用dll的无参数函数,为什么会不成功呢?

weixin_45739614 2020-03-18 11:01:12
动态调用dll的无参数函数,为什么会不成功呢?

’类模块:APIClass,
Option Explicit
'==============================================================================
'数据类型定义
'==============================================================================
Private Type VariableBuffer
VariableParameter() As Byte
End Type
'==============================================================================
'API 函数声明
'==============================================================================
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, APIScript As String) As Long
Dim hProcAddress As Long, hModule As Long, X As Long, Y As Long
Dim RetLong As Long, FunctionName As String, FunctionParameter As String
Dim LongCount As Long, StringInfo As String, StrByteArray() As VariableBuffer
Dim StringSize As Long, ByteArray() As Byte, IsHaveParameter As Boolean
Dim ParameterArray() As String, OutputArray() As Long
StringSize = 0
ReDim StrByteArray(StringSize)
'识别函数名称
RetLong = InStr(1, APIScript, " ", vbTextCompare)
If RetLong = 0 Then
'没有参数的函数
FunctionName = APIScript
IsHaveParameter = False
Else
'带参数的函数
FunctionName = Left(APIScript, RetLong - 1)
IsHaveParameter = True

'识别函数参数
FunctionParameter = Right(APIScript, Len(APIScript) - RetLong)

'分析函数参数
ParameterArray = Split(FunctionParameter, ",")

'初始化函数内存大小
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)
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
StringSize = StringSize + 1
End If
End If
Next X
ReDim m_OpCode(400 + 6 * UBound(OutputArray)) '保留用来写m_OpCode
End If

'读取API库
hModule = LoadLibrary(ByVal LibPath)
If hModule = 0 Then
ExecuteAPI = 0 'Library 读取失败
Exit Function
End If

'取得函数地址
hProcAddress = GetProcAddress(hModule, ByVal FunctionName)
If hProcAddress = 0 Then
ExecuteAPI = 0 '函数读取失败
FreeLibrary hModule
Exit Function
End If

If IsHaveParameter = True Then
'带参数的情况在此执行
ExecuteAPI = CallWindowProc(GetCodeStart(hProcAddress, OutputArray), 0, 1, 2, 3)
Else
'不带参数的情况在此执行
ExecuteAPI = CallWindowProc(hProcAddress, 0, 1, 2, 3)
End If

'释放库空间
FreeLibrary hModule
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
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
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

‘窗体部分
Private Sub Command1_Click()
Dim API As New APIClass, i As Long
i = API.ExecuteAPI("C:/Windows/SysWOW64/SkinH.dll", "SkinH_Attach")
MsgBox i
End Sub


SkinH_Attach为SkinH.dll中的一个没有参数的函数,为什么会调用不成功呢??很费解,求高手帮助!!
...全文
137 回复 打赏 收藏 转发到动态 举报
写回复
用AI写文章
回复
切换为时间正序
请发表友善的回复…
发表回复

1,486

社区成员

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧