Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetProcByName Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal nOrdinal As Long) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function IsWindowUnicode Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Byte)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)
Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Byte)
Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer)
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub PutMem8 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Currency)
Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Public Enum eObjType 'Object type for CallbackObj... also incorporates vTable offsets
objCls = &H1C 'Class object callback
objFrm = &H6F8 'Form object callback
objCtl = &H7A4 'UserControl object callback
End Enum '
'
Public Enum eReturnType 'CallFunc/CallPointer return types... also incorporates return type jump values
retByte = &H0 'Return Byte
retInteger = &H4 'Return Integer
retLong = &H9 'Return Long
retInt64 = &HD 'Return 64 bit value eg. Currency
retSingle = &H14 'Return Single
retDouble = &H18 'Return Double
retSub = &H1A 'No return value
End Enum '
'
Private Const SRC As String = "cCallFunc2." 'Error source
'
Private Type tParamBlock 'Parameter block type
ParamCount As Long 'Number of parameters
Params(0 To 59) As Long 'Array of parameters
End Type '
'
Private m_FastCall As Boolean 'FastCall private property value
Private m_LastError As Long 'LastError private property value
Private bUnicode As Boolean 'Unicode flag '
Private vCode As Long 'Pointer to the machine-code thunks
Private vTable As Long 'Class vTable address
Private nAddrPb As Long 'Address of the parameter block
Private hModule As Long 'Current/last-used dll handle
Private strLastDLL As String 'Current/last-used dll name
Private strLastFunc As String 'Current/last-used function/sub name
Private pb As tParamBlock 'Parameter block
'CallFunc:
'
' strDLL - Name of the DLL
' RetType - Function return type
' strFunc - Name of the function or it's ordinal value preceded by a '#' eg. "#2"
' ParamLongs - Any number [or none] of parameters As Long.
' To pass the address (ByRef) of a string use StrPtr, eg. StrPtr(strPath)
' To pass the address (ByRef) of a variable or UDT use VarPtr, eg. VarPtr(i)
Public Function CallFunc(ByRef strDll As String, _
ByVal RetType As eReturnType, _
ByRef strFunc As String, _
ParamArray ParamLongs() As Variant) As Variant '
Dim bNewDll As Boolean 'New dll flag
'
If StrComp(strDll, strLastDLL, vbTextCompare) <> 0 Then 'If the module is new
Dim hMod As Long '
'
If bUnicode Then 'If unicode
hMod = LoadLibraryW(StrPtr(strDll & vbNullChar)) 'Load the module with the unicode version of LoadLibrary
Else '
hMod = LoadLibraryA(strDll) 'Load the module with the ascii version of LoadLibrary
End If '
'
If hMod = 0 Then 'If the load failed
Debug.Assert False 'Halt if running under the VB IDE
Err.Raise vbObjectError + 0, SRC & "CallFunc", "DLL failed load" 'Raise an error if running compiled
End If '
'
If hModule <> 0 Then 'If a module is already loaded
FreeLibrary hModule 'Free the last module
End If '
'
hModule = hMod 'Save the module handle
strLastDLL = strDll 'Save the new module name
bNewDll = True 'Indicate that it's a new module
End If '
'
If bNewDll Or StrComp(strFunc, strLastFunc, vbBinaryCompare) <> 0 Then 'If the function or module is new
Dim fnAddress As Long 'Function address
'
If Asc(strFunc) = 35 Then 'If "#..." eg "#2", ordinal 2
fnAddress = GetProcByOrdinal(hModule, CLng(Mid$(strFunc, 2))) 'Get the address of the function by ordinal
Else '
fnAddress = GetProcByName(hModule, strFunc) 'Get the address of the function by name
End If '
'
If fnAddress = 0 Then 'If the function wasn't found in the module
Debug.Assert False 'Halt if running under the VB IDE
Err.Raise vbObjectError + 1, SRC & "CallFunc", "Function not found" 'Raise an error if running compiled
End If '
'
strLastFunc = strFunc 'Save the function name
PutMem4 vCode + &H19, fnAddress - vCode - (&H19 + 4) 'Patch the code with the relative address to the target function
End If '
'
With pb '
Dim i As Long 'Parameter loop vars
Dim j As Long 'Parameter loop vars
'
j = UBound(ParamLongs) 'Get the upper parameter array bound
For i = 0 To j 'For each parameter
.Params(i) = ParamLongs(i) 'Store the parameter in the parameter block
Next i '
'
.ParamCount = i 'Store the parameter count (j + 1)
End With '
'
CallFunc = CallCommon(RetType) 'Call common code
End Function '
'CallPointer: call a function by address
'
' RetType - Function return type
' fnAddress - Address of the target function
' ParamLongs - Any number of parameters As Long, or none.
' To pass the address (ByRef) of a string use StrPtr, eg. StrPtr(strPath)
' To pass the address (ByRef) of a variable or UDT use VarPtr, eg. VarPtr(i)
Public Function CallPointer(ByVal RetType As eReturnType, _
ByVal fnAddress As Long, _
ParamArray ParamLongs() As Variant) As Variant '
Dim i As Long 'Parameter loop vars
Dim j As Long 'Parameter loop vars
'
With pb '
j = UBound(ParamLongs) 'Get the upper parameter array bound
For i = 0 To j 'For each parameter
.Params(i) = ParamLongs(i) 'Store the parameter in the parameter block
Next i '
'
.ParamCount = i 'Store the parameter count (j + 1)
End With '
'
strLastFunc = vbNullString 'Ensure we don't clash with CallFunc caching
PutMem4 vCode + &H19, fnAddress - vCode - (&H19 + 4) 'Patch the code with the relative address to the target function
CallPointer = CallCommon(RetType) 'Call common code
End Function
'CallbackCdecl: return a wrapper address for a bas module routine to be used as a callback for a cdecl function.
' Note: stdcall functions don't need a thunk to use a bas module function as a callback, use direct.
'
' nModFuncAddr - The address of the bas module callback function, use AddressOf to get this value
' nParms - The number of parameters that will be passed to the bas module callback function
' nIndex - Allow for multiple simultaneous callbacks
Public Function CallbackCdecl(ByVal nModFuncAddr As Long, _
ByVal nParams As Long, _
Optional ByVal nIndex As Long = 1) As Long
If nIndex < 1 Or nIndex > 60 Or nParams > 60 Then 'Parameter sanity checks
Debug.Assert False 'Halt if running under the VB IDE
CallbackCdecl = vCode + 128 + ((nIndex - 1) * 64) 'Address of the callback wrapper. Pass this return value as the callback address parameter of the cdecl function
