'bind cdecl api to vb6 function
it's support vb6 ide,exe,excel vba
--------------
FixCdecl AddressOf VB_Add, CdeclApi, 2
c = VB_Add(a, b)
FORM1 CODE:
Module1.bas
it's support vb6 ide,exe,excel vba
--------------
FixCdecl AddressOf VB_Add, CdeclApi, 2
c = VB_Add(a, b)
FORM1 CODE:
Code:
Dim h As Long
Dim CdeclApi_Add As Long
Private Sub Command1_Click()
If CdeclApi_Add = 0 Then
h = LoadLibrary("cdecl.dll")
CdeclApi_Add = GetProcAddress(h, "Add")
FixCdecl GetAddress(AddressOf VB_Add), CdeclApi_Add, 2
End If
Dim a As Long, b As Long, c As Long
a = 44
b = 55
c = VB_Add(a, b)
MsgBox "c=" & c
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
RestoreFunctionMemory
FreeLibrary h
End SubCode:
Option Explicit
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function WriteProcessMemory2 Lib "kernel32" Alias "WriteProcessMemory" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualProtect2 Lib "kernel32" Alias "VirtualProtect" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long '设置内存可读写
Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Dim OldFunctionAsm(18) As Byte, FunctionPtr As Long, THUNK_SIZE As Long
'演示用，最简化代码
Function VB_Add(ByVal a As Long, ByVal b As Long, Optional NoUsed As Long) As Long
MsgBox 1
MsgBox 1
MsgBox 1
End Function
Sub FixCdecl(VbFunction As Long, CdeclApi As Long, Args As Long) 'GOOD
'MsgBox "call-FixCdecl"
Dim Asm(4) As String, Stub() As Byte ', THUNK_SIZE As Long
' 0: 58 pop eax
' 1: 89 84 24 XX XX XX XX mov dword ptr [esp+Xh],eax
Asm(0) = "58 89 84 24 " & LongToHex(Args * 4) '&H24848958
Asm(1) = "B8 " & LongToHex(CdeclApi) 'B8 90807000 MOV EAX,708090
Asm(2) = "FF D0" 'FFD0 CALL EAX
Asm(3) = "83 C4 " & Hex(Args * 4) '83 C4 XX add esp, XX 'cleanup args
Asm(4) = "C3"
Stub() = toBytes(Join(Asm, " "))
THUNK_SIZE = UBound(Stub) + 1
Dim bInIDE As Boolean
Debug.Assert pvSetTrue(bInIDE)
If bInIDE Then
CopyMemory2 VbFunction, ByVal VbFunction + &H16, 4
Else
VirtualProtect2 VbFunction, THUNK_SIZE, PAGE_EXECUTE_READWRITE, 0 '更改函数地址所在页面属性
End If
FunctionPtr = VbFunction
CopyMemory2 ByVal VarPtr(OldFunctionAsm(0)), ByVal VbFunction, THUNK_SIZE '保存函数旧数据
WriteProcessMemory2 -1, VbFunction, VarPtr(Stub(0)), THUNK_SIZE, 0
End Sub
Sub RestoreFunctionMemory() '恢复原来函数的部分汇编代码,必不可少，否则会崩
If THUNK_SIZE > 0 Then
WriteProcessMemory2 -1, FunctionPtr, VarPtr(OldFunctionAsm(0)), THUNK_SIZE, 0
End If
End Sub
Function toBytes(x As String) As Byte()
Dim tmp() As String
Dim fx() As Byte
Dim i As Long
tmp = Split(x, " ")
ReDim fx(UBound(tmp))
For i = 0 To UBound(tmp)
fx(i) = CInt("&h" & tmp(i))
Next
toBytes = fx()
End Function
Function LongToHex(x As Long) As String
Dim b(1 To 4) As Byte
CopyMemory2 b(1), x, 4
LongToHex = Hex(b(1)) & " " & Hex(b(2)) & " " & Hex(b(3)) & " " & Hex(b(4))
End Function
Function pvSetTrue(bValue As Boolean) As Boolean
bValue = True
pvSetTrue = True
End Function
Function GetAddress(ByVal V As Long) As Long
GetAddress = V
End Function