Option Explicit
Private Declare Function GetExitCodeThread Lib "kernel32" ( _
ByVal hThread As Long, _
lpExitCode As Long) As Long
Private Declare Function CreateThread Lib "kernel32" ( _
lpThreadAttributes As Long, _
ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, _
lpParameter As Any, _
ByVal dwCreationFlags As Long, _
lpThreadId As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" ( _
ByVal adr As Long, _
ByVal p1 As Long, _
ByVal p2 As Long, _
ByVal p3 As Long, _
ByVal p4 As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" ( _
ByVal szLib As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As Long, _
ByVal szFnc As String) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" ( _
ByVal szModule As String) As Long
Private Declare Sub RtlFillMemory Lib "kernel32" ( _
pDst As Any, _
ByVal dlen As Long, _
ByVal Fill As Byte)
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
pDst As Any, _
pSrc As Any, _
ByVal dlen As Long)
Private Const STILL_ACTIVE As Long = 259&
Private Const MAXCODE As Long = &HEC00&
Public Type ASYNCCALL
hThread As Long
ret As Long
asm(MAXCODE - 1) As Byte
End Type
Private lngAsyncRet As Long
' like GetProcAddress, but with a more comfortable first parameter
Public Function GetFncAddress(ByVal library As String, ByVal sFunction As String) As Long
Dim hModule As Long
Dim pFunc As Long
' check if module already loaded
hModule = GetModuleHandleA(library)
If hModule = 0 Then
' module not loaded, try to load it
hModule = LoadLibraryA(library)
If hModule = 0 Then
Err.Raise 999, , "library missing!"
Exit Function
End If
End If
' get entry point of function
pFunc = GetProcAddress(hModule, sFunction)
If pFunc = 0 Then
Err.Raise 998, , "not a exported function!"
Exit Function
End If
GetFncAddress = pFunc
End Function
' wait for end of thread
Public Sub WaitForThread(hThread As Long)
Dim dwExitCode As Long
Do
GetExitCodeThread hThread, dwExitCode
If dwExitCode <> STILL_ACTIVE Then Exit Do
DoEvents
Loop
End Sub
' run a function in a new thread
Public Sub CallPointerAsync(ByVal fnc As Long, udtAsync As ASYNCCALL, ParamArray params())
Dim pASM As Long
Dim TID As Long
Dim hThread As Long
Dim i As Integer
pASM = VarPtr(udtAsync.asm(0))
' fill code array with INT 3s (Debugger)
RtlFillMemory ByVal pASM, MAXCODE, &HCC
AddByte pASM, &H58 ' POP EAX
AddByte pASM, &H59 ' POP ECX
AddByte pASM, &H50 ' PUSH EAX
For i = UBound(params) To 0 Step -1
AddPush pASM, CLng(params(i)) ' PUSH dword
Next
AddCall pASM, fnc ' CALL rel. addr
AddByte pASM, &HBA ' MOV EDX, |||||
AddLong pASM, VarPtr(udtAsync.ret) ' dword
AddByte pASM, &H89 ' MOV ||||| ||| |||||, EAX
AddByte pASM, &H2 ' dword ptr [EDX]
AddByte pASM, &HC3 ' RET
hThread = CreateThread(ByVal 0&, 0, VarPtr(udtAsync.asm(0)), _
ByVal 0&, 0, TID)
udtAsync.hThread = hThread
End Sub
' run function by its pointer
Public Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long
Dim btASM(MAXCODE - 1) As Byte
Dim pASM As Long
Dim i As Integer
pASM = VarPtr(btASM(0))
' fill code array with INT 3s (Debugger)
RtlFillMemory ByVal pASM, MAXCODE, &HCC
' remove CallWindowProc parameters from stack
AddByte pASM, &H58 ' POP EAX
AddByte pASM, &H59 ' POP ECX
AddByte pASM, &H59 ' POP ECX
AddByte pASM, &H59 ' POP ECX
AddByte pASM, &H59 ' POP ECX
AddByte pASM, &H50 ' PUSH EAX
For i = UBound(params) To 0 Step -1
AddPush pASM, CLng(params(i)) ' PUSH dword
Next
AddCall pASM, fnc ' CALL rel addr
AddByte pASM, &HC3 ' RET
CallPointer = CallWindowProcA(VarPtr(btASM(0)), _
0, 0, 0, 0)
End Function
Private Sub AddPush(pASM As Long, lng As Long)
AddByte pASM, &H68
AddLong pASM, lng
End Sub
Private Sub AddCall(pASM As Long, addr As Long)
AddByte pASM, &HE8
AddLong pASM, addr - pASM - 4
End Sub
Private Sub AddLong(pASM As Long, lng As Long)
RtlMoveMemory ByVal pASM, lng, 4
pASM = pASM + 4
End Sub
Private Sub AddByte(pASM As Long, bt As Byte)
RtlMoveMemory ByVal pASM, bt, 1
pASM = pASM + 1
End Sub