The latest version has perfect support for running in the IDE, no need to press CTRL+F5
In VB6 ide, you need to press CTRL+F5 to run, or press F5 twice before running.
After compiling it into EXE, there is no problem at all.
This method can support DLL API calls of any other CDECL
The API binding in each DLL jumps to the functions in the VB6 module and is written to the assembly code. When the program ends, the code written by these functions needs to be recycled
Otherwise, it will cause a breakdown. These are just some of my ideas, not necessarily correct. For reference only, there may be better ways.
FixCdeclBas.bas
sqliltetest.bas
In VB6 ide, you need to press CTRL+F5 to run, or press F5 twice before running.
After compiling it into EXE, there is no problem at all.
This method can support DLL API calls of any other CDECL
The API binding in each DLL jumps to the functions in the VB6 module and is written to the assembly code. When the program ends, the code written by these functions needs to be recycled
Otherwise, it will cause a breakdown. These are just some of my ideas, not necessarily correct. For reference only, there may be better ways.
FixCdeclBas.bas
Code:
Option Explicit
Public Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Public Declare Function VirtualLock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long
Public Declare Function VirtualUnlock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long
Private Declare Function CallAsm Lib "user32" _
Alias "CallWindowProcA" ( _
ByRef lpBytes As Any, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
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
Public 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
Public Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, 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
Public Const THUNK_SIZE As Long = 24 '19
Private Type FunctionOldInfo
Oldbt(23) As Byte
VbFunction2 As Long
MemPtr As Long
End Type
Dim OldInfoArr() As FunctionOldInfo, ApiCount As Long
Public bInIDE As Boolean, AsmCall_INide As Boolean
Function VB_Add(ByVal a As Long, ByVal b As Long, Optional NoUsed As Long) As Long
MsgBox 1
MsgBox 1
End Function
Sub FixCdecl(ByVal VbFunction As Long, ByVal CdeclApi As Long, Args As Long) 'GOOD
If AsmCall_INide Then Exit Sub
'MsgBox "call-FixCdecl"
Dim asm(4) As String, stub() As Byte
' 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, " "))
' MsgBox bInIDE
If bInIDE Then
CopyMemory2 VbFunction, ByVal VbFunction + &H16, 4 'ide下必须用这个,编绎后不可行
Else
VirtualProtect2 VbFunction, THUNK_SIZE, PAGE_EXECUTE_READWRITE, 0 '更改函数地址所在页面属性
'ide下不可用，编绎后只能用这个
End If
ReDim Preserve OldInfoArr(ApiCount)
'OldInfoArr(ApiCount).MemPtr = VirtualAlloc(ByVal 0&, 4096, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
OldInfoArr(ApiCount).VbFunction2 = VbFunction
CopyMemory2 ByVal VarPtr(OldInfoArr(ApiCount).Oldbt(0)), ByVal VbFunction, ByVal THUNK_SIZE '保存函数旧数据
ApiCount = ApiCount + 1
If bInIDE Then
' CopyMemory2 ByVal VbFunction, ByVal VarPtr(stub(0)), THUNK_SIZE 'only support ide
WriteProcessMemory2 -1, VbFunction, VarPtr(stub(0)), THUNK_SIZE, 0
'WriteProcessMemory -1, ByVal VbFunction, stub(0), THUNK_SIZE, 0
Else
WriteProcessMemory2 -1, VbFunction, VarPtr(stub(0)), THUNK_SIZE, 0
End If
End Sub
Sub RestoreFunctionMemoryList() '必不可少，否则会崩
'If bInIDE Then Exit Sub
Dim I As Long
For I = 0 To ApiCount - 1
' If bInIDE Then 'CopyMemory2 ByVal OldInfoArr(I).VbFunction2, ByVal VarPtr(OldInfoArr(I).Oldbt(0)), ByVal THUNK_SIZE 'only support ide
WriteProcessMemory2 -1, OldInfoArr(I).VbFunction2, VarPtr(OldInfoArr(I).Oldbt(0)), THUNK_SIZE, 0
Next
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(V As Long) As Long
GetAddress = V
End Function
Function CallCdecl(lpfn As Long, ParamArray Args()) As Long
'支持IDE中运行
Dim asm() As String
Dim stub() As Byte
Dim I As Long
Dim argSize As Byte
Dim Ret As Long
'we step through args backwards to preserve intutive ordering
For I = UBound(Args) To 0 Step -1
If Not IsNumeric(Args(I)) Then
MsgBox "CallCdecl Invalid Parameter #" & I & " TypeName=" & TypeName(Args(I))
Exit Function
End If
push asm(), "68 " & LongToHex(CLng(Args(I))) '68 90807000 PUSH 708090
argSize = argSize + 4
Next
push asm(), "B8 " & LongToHex(lpfn) 'B8 90807000 MOV EAX,708090
push asm(), "FF D0" 'FFD0 CALL EAX
push asm(), "83 C4 " & Hex(argSize) '83 C4 XX add esp, XX 'Cleanup args
push asm(), "C2 10 00" 'C2 10 00 retn 10h
'Cleanup our callwindowproc args
stub() = toBytes(Join(asm, " "))
CallCdecl = CallAsm(stub(0), 0, 0, 0, 0)
End Function
Function getESP() As Long
Dim c As Currency '8 bytes, initially all 0's
'8BC4 MOV EAX,ESP
'C2 10 00 retn 10h
CopyMemory2 c, &H10C2C48B, 4
getESP = CallAsm(c, 0, 0, 0, 0)
End Function
Sub push(ary, value) 'this modifies parent ary object
On Error GoTo init
Dim x As Long
x = UBound(ary) '<-throws Error If Not initalized
ReDim Preserve ary(UBound(ary) + 1)
ary(UBound(ary)) = value
Exit Sub
init:
ReDim ary(0): ary(0) = value
End SubCode:
Option Explicit
Private Declare Function WideCharToMultiByteNstr Lib "kernel32" Alias "WideCharToMultiByte" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Const SQLITE_OK As Long = 0
Private Const SQLITE_ROW As Long = 100
Private Declare Function SysAllocString Lib "oleaut32" ( _
ByRef pOlechar As Any) As Long
Private Declare Function PutMem4 Lib "msvbvm60.dll" ( _
ByRef pDst As Any, _
ByVal lVal As Long) As Long
Public h As Long
Public Bt() As Byte
Public CdeclApi(10) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001
Sub Main()
'Press CTRL+5 to run, or press F5 twice before it can run normally
'按CTRL+5运行，或者按F5两次后才能正常运行
Debug.Assert pvSetTrue(bInIDE) 'get value bInIDE
If bInIDE Then AsmCall_INide = True 'Enable this code without pressing CTRL+F5 to run
BindCdeclToVbFunction
DoTest
RestoreFunctionMemoryList
FreeLibrary h
End Sub
Sub DoTest()
Dim pDB As Long
Dim pStmt As Long
Dim lResult As Long
Dim sBstrRes As String
Dim pzTail As Long
Dim startESP As Long, endEsp As Long
startESP = getESP
lResult = VB_sqlite3_open(StrToBytePtr(":memory:"), VarPtr(pDB))
endEsp = getESP
MsgBox IIf(endEsp - startESP = 0, "No problem with ESP", "Esp err:" & endEsp - startESP) & ",pDB=" & pDB
If lResult <> SQLITE_OK Or pDB = 0 Then
MsgBox "Cannot open database", vbCritical
GoTo CleanUp
End If
lResult = VB_sqlite3_prepare_v2(pDB, StrToBytePtr("SELECT SQLITE_VERSION()"), ByVal -1&, VarPtr(pStmt), VarPtr(pzTail), 0&)
If lResult <> SQLITE_OK Then
MsgBox "Cannot open database-2", vbCritical
GoTo CleanUp
End If
lResult = VB_sqlite3_step(pStmt)
If lResult = SQLITE_ROW Then
PutMem4 ByVal VarPtr(sBstrRes), SysAllocString(ByVal VB_sqlite3_column_text16(pStmt, 0))
Debug.Print sBstrRes
MsgBox "SQLITE Version:" & sBstrRes
End If
CleanUp:
If pStmt Then VB_sqlite3_finalize pStmt
If pDB Then VB_sqlite3_close pDB
endEsp = getESP
MsgBox IIf(endEsp - startESP = 0, "No problem with ESP", "Esp err:" & endEsp - startESP) & ",pDB=" & pDB, , "Test Done"
End Sub
Sub BindCdeclToVbFunction()
'要用到的CDECL API在这里包装成VB的函数过程就可以直接调用了
'fix all cdecl api
h = LoadLibrary(App.Path & "\sqlite3.dll")
CdeclApi(0) = GetProcAddress(h, "sqlite3_open")
FixCdecl GetAddress(GetAddress(AddressOf VB_sqlite3_open)), CdeclApi(0), 2
'Exit Sub
CdeclApi(1) = GetProcAddress(h, "sqlite3_prepare_v2")
FixCdecl GetAddress(GetAddress(AddressOf VB_sqlite3_prepare_v2)), CdeclApi(1), 5
CdeclApi(2) = GetProcAddress(h, "sqlite3_step")
FixCdecl GetAddress(AddressOf VB_sqlite3_step), CdeclApi(2), 1
CdeclApi(3) = GetProcAddress(h, "sqlite3_finalize")
FixCdecl GetAddress(AddressOf VB_sqlite3_finalize), CdeclApi(3), 1
CdeclApi(4) = GetProcAddress(h, "sqlite3_close")
FixCdecl GetAddress(AddressOf VB_sqlite3_close), CdeclApi(4), 1
CdeclApi(5) = GetProcAddress(h, "sqlite3_column_text16")
FixCdecl GetAddress(AddressOf VB_sqlite3_column_text16), CdeclApi(5), 2
End Sub
Function VB_sqlite3_open(ByVal filename As Long, ByVal ppDB As Long, Optional ByVal NoUsed As Long) As Long
If Not AsmCall_INide Then MsgBox "call cdecl err:CallCdecl(sqlite3_open)"
VB_sqlite3_open = CallCdecl(CdeclApi(0), filename, ppDB)
End Function
Function VB_sqlite3_prepare_v2(ByVal db As Long, _
ByVal zSql As Long, _
ByVal nByte As Long, _
ByVal ppStmt As Long, _
ByVal pzTail As Long, Optional ByVal NoUsed As Long) As Long
VB_sqlite3_prepare_v2 = CallCdecl(CdeclApi(1), db, zSql, nByte, ppStmt, pzTail)
End Function
Function VB_sqlite3_step(ByVal pStmt As Long, Optional ByVal NoUsed As Long) As Long
VB_sqlite3_step = CallCdecl(CdeclApi(2), pStmt)
End Function
Function VB_sqlite3_finalize(ByVal pStmt As Long, Optional ByVal NoUsed As Long) As Long
VB_sqlite3_finalize = CallCdecl(CdeclApi(3), pStmt)
End Function
Function VB_sqlite3_close(ByVal ppDB As Long, Optional ByVal NoUsed As Long) As Long
VB_sqlite3_close = CallCdecl(CdeclApi(4), ppDB)
End Function
Function VB_sqlite3_column_text16(ByVal pStmt As Long, ByVal iCol As Long, Optional ByVal NoUsed As Long) As Long
VB_sqlite3_column_text16 = CallCdecl(CdeclApi(5), pStmt, iCol)
End Function
Sub UnicodeToUTF8Byte(sData As String, bvData() As Byte, Optional Add0 As Boolean)
Dim lSize As Long, lRet As Long, Len1 As Long
Len1 = Len(sData)
If Len1 > 0 Then
lSize = Len1 * 4
ReDim bvData(lSize)
lRet = WideCharToMultiByteNstr(CP_UTF8, 0, StrPtr(sData), Len1, bvData(0), lSize, vbNullString, 0)
If Add0 Then
ReDim Preserve bvData(lRet)
Else
ReDim Preserve bvData(lRet - 1)
End If
End If
End Sub
Function StrToBytePtr(Str As String) As Long
Bt() = StrConv(Str & Chr(0), vbFromUnicode)
StrToBytePtr = VarPtr(Bt(0))
'
' UnicodeToUTF8Byte Str, Bt, False
' StrToBytePtr = VarPtr(Bt(0))
End Function