總共就兩個部分，第一部分說幾個聲明API并使用的技巧，第二部分簡單講一下怎么動態(tài)調(diào)用DLL
玩API的人看到前面的描述肯定會心里MMP，廢話少說，看內(nèi)容。
1、相對路徑聲明
這個最好理解
普通的API聲明長這樣：
下面是其FullPath版本的聲明：
Declare Function LZ4_versionNumber Lib 'c:\liblz4.dll' Alias '_LZ4_versionNumber@0' () As Long
下面是其相對路徑版本的聲明：
這特么怎么這么復(fù)雜呢，這三種都可以？下面也就簡單一解釋，不做深入研究，各位看官也就看看就好，能記住就記住。
先說FullPath版本，這是最低級的使用方法，一般人不會這么用；還有一種方法也可以指定FullPath，那就是使用manifest，manifest是個好東西，這個以后再扒。
然后是普通的API和相對路徑的API，這倆其實是一個原理：
對于VB6，怎么檢索DLL呢，當(dāng)然是先檢索App.Path（1、不檢索子目錄；2、VBA里對應(yīng)Application.Path）
然后再檢索環(huán)境變量目錄
很多人不知道怎么看環(huán)境變量，Win R，cmd，輸入set，enter，就看到了所有環(huán)境變量
上述DLL靜態(tài)聲明，會在當(dāng)前目錄和所有環(huán)境變量目錄，以相對路徑檢索DLL（如果多個路徑都檢索到，這個要應(yīng)用檢索規(guī)則，這里也不扒了）
假設(shè)環(huán)境變量中有一個路徑：c:\xxx
那么API中的'..\Plugins\liblz4'和'liblz4'，就分別對應(yīng)了路徑：
'c:\xxx\..\Plugins\liblz4.dll'和'c:\xxx\liblz4.dll'
上面'..'的意思是指上一級目錄，也即
'c:\xxx\..\Plugins\liblz4.dll' = 'c:\Plugins\liblz4.dll'
2、動態(tài)路徑
先說怎么用，聲明就跟普通聲明方式一樣：
Declare Function LZ4_versionNumber Lib 'liblz4' Alias '_LZ4_versionNumber@0' () As Long
但是，如果這時候在環(huán)境變量目錄下都沒有這個dll的話
在使用這個dll之前，我們可以用LoadLibrary這個API來加載一下dll，就可以調(diào)用'LZ4_versionNumber'了
Declare聲明函數(shù)時，是聲明函數(shù)指針，并指明入口點(diǎn)，VB6會通過內(nèi)部函數(shù)DllFunctionCall（該函數(shù)會調(diào)用LoadLibraryA）來調(diào)用外部API
如果Declare時，在所有路徑都找不到DLL，而這時候，你主動使用LoadLibrary加載了該DLL
這時候，就解決了加載DLL的問題，相當(dāng)于運(yùn)行時重定向DLL
3、修改環(huán)境變量
VB6程序在加載時，會優(yōu)先加載App.Path
然后會加載進(jìn)程環(huán)境變量，進(jìn)程環(huán)境變量
這里相關(guān)的API有5個，這里用到的就前2個：
然后加環(huán)境變量就是這樣操作：
Dim lngRet As Long Dim strDest As String Dim arr() As String, i As Long Dim boolIn As Boolean '路徑是否在環(huán)境變量中 Const MAX_BUFFER = 9000& strDest = String$(MAX_BUFFER, Chr(0)) GetEnvironmentVariableA 'Path', strDest, MAX_BUFFER 1 '獲取當(dāng)前進(jìn)程的Path環(huán)境變量 lngRet = InStr(strDest, Chr(0)) strDest = Left(strDest, lngRet - 1) '清掉緩存字符 arr = Split(strDest, ';') '判斷路徑是否已經(jīng)在環(huán)境變量中 For i = LBound(arr) To UBound(arr) If arr(i) = strMatch Then boolIn = True Exit For End If Next i If boolIn = False Then SetEnvironmentVariableA 'Path', strDllPath & ';' & strDest '設(shè)置當(dāng)前進(jìn)程的Path環(huán)境變量，加在最前面 End If
這樣設(shè)置之后，檢測DLL的時候，就多了一個自定義設(shè)置的strDllPath路徑了
以下內(nèi)容多且復(fù)雜，初學(xué)者直接跳過，由于這里對外鏈卡得比較嚴(yán)，我就只敢貼代碼。
所以，需要探討的，在評論里交流
很多時候，開發(fā)者不想寫那么多Declare，就論這個問題，其實有兩個解決方案。
一個是使用tlb，現(xiàn)在有很多包含win32api的tlb文件，tlb文件制作簡單，在編寫代碼時引用到工程里，發(fā)布程序時不需要附帶tlb文件
還有一種方案就是動態(tài)調(diào)用：
說起來方法其實很簡單
第1步：LoadLibrary，加載DLL模塊到內(nèi)存
第2步：GetProcAddress，獲取DLL里的API函數(shù)指針
第3步：CallWindowProc或者DispCallFunc，調(diào)用函數(shù)
第4步：FreeLibrary，用完了釋放函數(shù)
但是如果真的要自己去研究，而且要支持多種調(diào)用約定的話，就比較麻煩了。
像CallWindowProc，在不寫匯編代碼的情況下，只能支撐有4個參數(shù)的API
這里當(dāng)然不會講怎么寫匯編代碼，所以這里推薦幾個已有的輪子：
不用知其所以然，只用知道怎么用就好。
第1個：DispCallFunc方案
vbforums論壇高人Lavolpe寫的類cUniversalDLLCalls.cls，理論上支持9種調(diào)用約定
' for documentation on the main API DispCallFunc... http://msdn.microsoft.com/en-us/library/windows/desktop/ms221473%28v=vs.85%29.aspx
Private Declare Function DispCallFunc Lib 'oleaut32.dll' (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Function GetModuleHandle Lib 'kernel32.dll' Alias 'GetModuleHandleA' (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib 'kernel32.dll' (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib 'kernel32.dll' Alias 'LoadLibraryA' (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib 'kernel32.dll' (ByVal hLibModule As Long) As Long
Private Declare Sub CopyMemory Lib 'kernel32.dll' Alias 'RtlMoveMemory' (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib 'kernel32.dll' Alias 'RtlFillMemory' (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare Sub SetLastError Lib 'kernel32.dll' (ByVal dwErrCode As Long)
Private Declare Function lstrlenA Lib 'kernel32.dll' (ByVal lpString As Long) As Long
Private Declare Function lstrlenW Lib 'kernel32.dll' (ByVal lpString As Long) As Long
' APIs used for _CDecl callback workarounds. See ThunkFor_CDeclCallbackToVB & ThunkRelease_CDECL
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
Public Enum CALLINGCONVENTION_ENUM
' http://msdn.microsoft.com/en-us/library/system.runtime.interopservices.comtypes.callconv%28v=vs.110%29.aspx
CC_FASTCALL = 0&
CC_CDECL
CC_PASCAL
CC_MACPASCAL
CC_STDCALL ' typical windows APIs
CC_FPFASTCALL
CC_SYSCALL
CC_MPWCDECL
CC_MPWPASCAL
End Enum
Public Enum CALLRETURNTUYPE_ENUM
CR_None = vbEmpty
CR_LONG = vbLong
CR_BYTE = vbByte
CR_INTEGER = vbInteger
CR_SINGLE = vbSingle
CR_DOUBLE = vbDouble
CR_CURRENCY = vbCurrency
' if the value you need isn't in above list, you can pass the value manually to the
' CallFunction_DLL method below. For additional values, see:
' http://msdn.microsoft.com/en-us/library/cc237865.aspx
End Enum
Public Enum STRINGPARAMS_ENUM
STR_NONE = 0&
STR_ANSI
STR_UNICODE
End Enum
Private m_DLLname As String ' track last DLL loaded by this class
Private m_Mod As Long ' reference to loaded module
Private m_Release As Boolean ' whether or not we unload the module/dll
Public Function CallFunction_DLL(ByVal LibName As String, ByVal FunctionName As String, _
ByVal HasStringParams As STRINGPARAMS_ENUM, _
ByVal FunctionReturnType As CALLRETURNTUYPE_ENUM, _
ByVal CallConvention As CALLINGCONVENTION_ENUM, _
ParamArray FunctionParameters() As Variant) As Variant
' Used to call standard dlls, not active-x or COM objects
' Return value. Will be a variant containing a value of FunctionReturnType
' If this method fails, the return value will always be Empty. This can be verified by checking
' the Err.LastDLLError value. It will be non-zero if the function failed else zero.
' If the method succeeds, there is no guarantee that the function you called succeeded. The
' success/failure of that function would be indicated by this method's return value.
' If calling a sub vs function & this method succeeds, the return value will be zero.
' Summarizing: if method fails to execute, Err.LastDLLError value will be non-zero
' If method executes ok, return value is from the DLL you called
' Parameters:
' LibName. The dll name. You should always include the extension else DLL is used
' See LoadLibrary documentation for more: http://msdn.microsoft.com/en-us/library/windows/desktop/ms684175%28v=vs.85%29.aspx
' FunctionName. The DLL function to call. This is case-senstiive
' To call a function by ordinal, prefix it with a hash symbol, i.e., #124
' HasStringParams. Provide one of the 3 available values
' STR_NONE. No parameters are strings or all strings are passed via StrPtr()
' STR_UNICODE. Any passed string values are for a Unicode function, i.e., SetWindowTextW
' STR_ANSI. Any passed string values are for an ANSI function, i.e., SetWindowTextA
' Important: If you pass one of FunctionParameters a String variable, you must include
' STR_UNICODE or STR_ANSI depending on what version function you are calling
' See the FunctionParameters section below for more
' FunctionReturnType. Describes what variant type the called function returns
' If calling a subroutine that does not return a value, use CR_None
' CallConvention. One of various DLL calling conventions
' You must know the calling convention of the function you are calling and the number
' of parameters, along with the parameter variable type
' FunctionParameters. The values and variant type for each value as required by the function
' you are calling. This is important. Passing incorrect variable types can cause crashes.
' There is no auto-conversion like VB would do for you if you were to call an API function.
' To ensure you pass the correct variable type, use VBs conversion routines:
' Passing a Long? CLng(10), CLng(x). Passing an Integer? CInt(10), CInt(x)
' Special cases:
' UDTs (structures). Pass these using VarPtr(), i.e., VarPtr(uRect)
' If UDT members contain static size strings, you should declare those string members
' as Byte arrays instead. When array is filled in by the function you called,
' you can use StrConv() to convert array to string.
' If UDT members contain dynamic size strings, you should declare those as Long.
' When the function returns, you can use built-in functions within this class to
' retrieve the string from the pointer provided to your UDT.
' Arrays. DO NOT pass the array. Pass only a pointer to the first member of the array,
' i.e., VarPtr(myArray(0)), VarPtr(myArray(0,0)), etc
' Strings for ANSI functions.
' 1) Passing by variable name or value? i.e., strContent, 'Edit', etc
' The string needs to be converted to ANSI, and this class will do that for you
' if you also pass HasStringParams as STR_ANSI. Otherwise, do NOT pass strings
' for ANSI functions by variable name or value. When passed by variable name,
' the variable contents are changed to 1 byte per character. To prevent this,
' pass the variable name inside parentheses, i.e., (myVariable)
' 2) Passing by StrPtr()? i.e, StrPtr(strContent), StrPtr('Edit')
' If the function you are calling needs the string contents, then do NOT pass
' the string this way. You must first convert it to ANSI. Else, you could
' pass it as desribed in #1 above.
' Rule-of-Thumb. If string is just a buffer, pass it by StrPtr(), then on return,
' use VB's StrConv() to convert it from ANSI to unicode. Otherwise, pass the
' string by variable name or value
' Strings for Unicode functions
' 1) Passing by variable name or value? i.e., strContent, 'Edit', etc
' Internally, the string must be passed to the function ByVal via StrPtr().
' This class will do that, but it is faster (less code) if you pass all strings
' for unicode functions via StrPtr()
' 2) Passing by StrPtr()? i.e, StrPtr(strContent), StrPtr('Edit')
' Less code required, fastest method, no conversions required at all
' Rule-of-Thumb. All strings for unicode functions should be passed via StrPtr()
' Numeric values vs. variables. Be aware of the variable type of the number you pass.
' Depending on the value of the number, it may be Integer, Long, Double, etc.
' Numbers in range -32768 to 32767 are Integer, from -2147483648 to 2147483647 are Long
' Fractional/decimal numbers are Double
' If function parameter expects Long, don't pass just 5, pass 5& or CLng(5)
' Numbers as variables. Be sure the variable type matches the parameter type, i.e.,
' dont pass variables declared as Variant to a function expecting Long
'// minimal sanity check for these 4 parameters:
If LibName = vbNullString Then Exit Function
If FunctionName = vbNullString Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function ' can only be 4 bytes
If HasStringParams < STR_NONE Or HasStringParams > STR_UNICODE Then Exit Function
Dim sText As String, lStrPtr As Long, lValue As Long
Const VT_BYREF As Long = &H4000&
Dim hMod As Long, fPtr As Long
Dim pIndex As Long, pCount As Long
Dim vParamPtr() As Long, vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
'// determine if we will be loading this or already loaded
If LibName = m_DLLname Then
hMod = m_Mod ' already loaded
Else
If Not m_Mod = 0& Then ' reset m_Mod & m_Release
If m_Release = True Then FreeLibrary m_Mod
m_Mod = 0&: m_Release = False
End If
hMod = GetModuleHandle(LibName) ' loaded in process already?
If hMod = 0& Then ' if not, load it now
hMod = LoadLibrary(LibName)
If hMod = 0& Then Exit Function
m_Release = True ' need to use FreeLibrary at some point
End If
m_Mod = hMod ' cache hMod & LibName
m_DLLname = LibName
End If
fPtr = GetProcAddress(hMod, FunctionName) ' get the function pointer (Case-Sensitive)
If fPtr = 0& Then Exit Function ' abort if failure
vParams() = FunctionParameters() ' copy passed parameters, if any
pCount = Abs(UBound(vParams) - LBound(vParams) 1&)
If HasStringParams > STR_NONE Then ' patch to ensure Strings passed as handles
For pIndex = 0& To pCount - 1& ' for each string param, get its StrPtr
If VarType(FunctionParameters(pIndex)) = vbString Then
CopyMemory lValue, ByVal VarPtr(FunctionParameters(pIndex)), 2&
If (lValue And VT_BYREF) = 0& Then ' else variant has pointer to StrPtr
lValue = VarPtr(FunctionParameters(pIndex)) 8&
Else
CopyMemory lValue, ByVal VarPtr(FunctionParameters(pIndex)) 8&, 4&
End If
CopyMemory lStrPtr, ByVal lValue, 4& ' get the StrPtr
If lStrPtr > 0& Then ' if not null then
If HasStringParams = STR_ANSI Then ' convert Unicode to ANSI
sText = FunctionParameters(pIndex) ' then re-write the passd String to ANSI
FillMemory ByVal lStrPtr, LenB(sText), 0
sText = StrConv(sText, vbFromUnicode)
CopyMemory ByVal lStrPtr, ByVal StrPtr(sText), LenB(sText)
End If
End If
vParams(pIndex) = lStrPtr ' reference the StrPtr
End If
Next
End If
' fill in rest of APIs parameters
If pCount = 0& Then ' no return value (sub vs function)
ReDim vParamPtr(0 To 0)
ReDim vParamType(0 To 0)
Else
ReDim vParamPtr(0 To pCount - 1&) ' need matching array of parameter types
ReDim vParamType(0 To pCount - 1&) ' and pointers to the parameters
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
' call the function now
lValue = DispCallFunc(0&, fPtr, CallConvention, FunctionReturnType, _
pCount, vParamType(0), vParamPtr(0), vRtn)
If lValue = 0& Then ' 0 = S_OK
If FunctionReturnType = CR_None Then
CallFunction_DLL = lValue
Else
CallFunction_DLL = vRtn ' return result
End If
Else
SetLastError lValue ' set error & return Empty
End If
End Function
Public Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, _
ByVal FunctionReturnType As CALLRETURNTUYPE_ENUM, _
ByVal CallConvention As CALLINGCONVENTION_ENUM, _
ParamArray FunctionParameters() As Variant) As Variant
' Used to call active-x or COM objects, not standard dlls
' Return value. Will be a variant containing a value of FunctionReturnType
' If this method fails, the return value will always be Empty. This can be verified by checking
' the Err.LastDLLError value. It will be non-zero if the function failed else zero.
' If the method succeeds, there is no guarantee that the Interface function you called succeeded. The
' success/failure of that function would be indicated by this method's return value.
' Typically, success is returned as S_OK (zero) and any other value is an error code.
' If calling a sub vs function & this method succeeds, the return value will be zero.
' Summarizing: if method fails to execute, Err.LastDLLError value will be non-zero
' If method executes ok, if the return value is zero, method succeeded else return is error code
' Parameters:
' InterfacePointer. A pointer to an object/class, i.e., ObjPtr(IPicture)
' Passing invalid pointers likely to result in crashes
' VTableOffset. The offset from the passed InterfacePointer where the virtual function exists.
' These offsets are generally in multiples of 4. Value cannot be negative.
' For the remaining parameters, see the details withn the CallFunction_DLL method.
' They are the same with one exception: strings. Pass the string variable name or value
'// minimal sanity check for these 4 parameters:
If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function ' can only be 4 bytes
Dim pIndex As Long, pCount As Long
Dim vParamPtr() As Long, vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters() ' copy passed parameters, if any
pCount = Abs(UBound(vParams) - LBound(vParams) 1&)
If pCount = 0& Then ' no return value (sub vs function)
ReDim vParamPtr(0 To 0)
ReDim vParamType(0 To 0)
Else
ReDim vParamPtr(0 To pCount - 1&) ' need matching array of parameter types
ReDim vParamType(0 To pCount - 1&) ' and pointers to the parameters
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
' call the function now
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, _
pCount, vParamType(0), vParamPtr(0), vRtn)
If pIndex = 0& Then ' 0 = S_OK
CallFunction_COM = vRtn ' return result
Else
SetLastError pIndex ' set error & return Empty
End If
End Function
Public Function PointerToStringA(ByVal ANSIpointer As Long) As String
' courtesy function provided for your use as needed
' ANSIpointer must be a pointer to an ANSI string (1 byte per character)
Dim lSize As Long, sANSI As String
If Not ANSIpointer = 0& Then
lSize = lstrlenA(ANSIpointer)
If lSize > 0& Then
sANSI = String$(lSize \ 2& 1&, vbNullChar)
CopyMemory ByVal StrPtr(sANSI), ByVal ANSIpointer, lSize
PointerToStringA = Left$(StrConv(sANSI, vbUnicode), lSize)
End If
End If
End Function
Public Function PointerToStringW(ByVal UnicodePointer As Long) As String
' courtesy function provided for your use as needed
' UnicodePointer must be a pointer to an unicode string (2 bytes per character)
Dim lSize As Long
If Not UnicodePointer = 0& Then
lSize = lstrlenW(UnicodePointer)
If lSize > 0& Then
PointerToStringW = Space$(lSize)
CopyMemory ByVal StrPtr(PointerToStringW), ByVal UnicodePointer, lSize * 2&
End If
End If
End Function
Public Function ThunkFor_CDeclCallbackToVB(ByVal VBcallbackPointer As Long, _
ByVal CallbackParamCount As Long) As Long
' this method is a workaround for cases where you are calling a CDECL function that requests
' a callback function address in CDECL calling convention.
' Ex: qsort in msvcrt20.dll uses such a callback & qsort function description found here:
' http://msdn.microsoft.com/en-us/library/zes7xw0h.aspx
' Important notes:
' 1) DO NOT USE this workaround when any function accepting a callback pointer,
' uses stdCall calling convention to that pointer. DO NOT USE this function
' for other than CDECL functions calling back to VB
' 2) This method's return value MUST BE RELEASED via a call to ThunkRelease_CDECL method
' 3) The VB callback function must be a function vs. sub, even if the the callback
' definition describes it as a sub, i.e., returns no value, void
' 4) The thunk prevents VB's stack cleaning by copying first, then replacing it after VB returns
' Parameters:
' VBcallbackPointer: the VB callback address. If function exists in a bas module, then
' this would be the return value of your AddressOf call. If using thunks to get addresses
' from class methods, then pass that thunk address as appropriate
' CallbackParamCount: Number of parameters your VB method accepts. This cannot be dynamic
' sample call: assume that vbCallBackFunction is a Public function within a bas module
' -------------------------------------------------------------------------------------
' Dim lCallback As Long, lThunkAddress As Long, lResult As Long
' lCallback = thisClass.ThunkFor_CDeclCallbackToVB(AddressOf vbCallBackFunction, 2&, lThunkAddress)
' ' now call your CDECL function, passing lCallback as the required callback address paramter,
' ' in whatever param position it is required
' lResult = thisClass.CallFunction_DLL('someCDECL.dll', 'functionName', STR_NONE, CR_LONG, _
' CC_CDECL, params, lCallback)
' ' destroy the thunk when no longer needed
' Call thisClass.ThunkRelease_CDECL(lThunkAddress)
' sanity checks on passed parameters
If VBcallbackPointer = 0& Or CallbackParamCount < 0& Or CallbackParamCount > 63& Then Exit Function
' FYI: Why is 63 the max count? CallbackParamCount stored in the thunk as unsigned byte: 63*4 =252
Dim fPtr As Long, tCode(0 To 2) As Currency
fPtr = VirtualAlloc(0&, 28&, &H1000&, &H40&) ' reserve memory for our virtual function
tCode(0) = 465203369712025.6232@ ' thunk code is small, 28 bytes
tCode(1) = -140418483381718.8329@
tCode(2) = -4672484613390.9419@
CopyMemory ByVal fPtr, ByVal VarPtr(tCode(0)), 24& ' copy to virt memmory
CopyMemory ByVal fPtr 24&, &HC30672, 4& ' copy final 4 bytes also
' thunk uses relative address to VB function address, calc relative address & patch the thunk
CopyMemory ByVal fPtr 10&, VBcallbackPointer - fPtr - 14&, 4&
CopyMemory ByVal fPtr 16&, CallbackParamCount * 4&, 1& ' patch thunk's param count (stack adjustment)
ThunkFor_CDeclCallbackToVB = fPtr
' FYI: Thunk described below. Paul Caton's work found here:
' http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=49776&lngWId=1
'==============================================================================
' ;FASM syntax
' use32 ;32bit
' call L1 ;Call the next instruction
' L1: pop eax ;Pop the return address into eax (eax = L1)
' pop dword [eax (L3-L1)] ;Pop the calling cdecl function's return address to the save location
' db 0E8h ;Op-code for a relative address call
' dd 55555555h ;Address of target vb callback function, patched at run-time
' sub esp, 55h ;Unfix the stack, our caller expects to do it, patched at runtime
' call L2 ;Call the next instruction
' L2: pop edx ;Pop the return address into edx (edx = L2)
' push dword [edx (L3-L2)];Push the saved return address, the stack is now as it was on entry to callback_wrapper
' ret ;Return to caller
' db 0 ;Alignment pad
' L3: dd 0 ;Return address of the cdecl caller saved here
'==============================================================================
End Function
Public Sub ThunkRelease_CDECL(ByVal ThunkCallBackAddress As Long)
' Used to release memory created during a call to the ThunkFor_CDeclCallbackToVB method.
' The parameter passed here must be the return value of the ThunkFor_CDeclCallbackToVB method
If Not ThunkCallBackAddress = 0& Then VirtualFree ThunkCallBackAddress, 0&, &H8000&
End Sub
Private Sub Class_Terminate()
If Not m_Mod = 0& Then
If m_Release = True Then FreeLibrary m_Mod
End If
End Sub
這個類強(qiáng)大的不行，使用起來也極其簡單：
stdcall和cdecl的支持已經(jīng)做進(jìn)來了，其他的沒有給應(yīng)用案例，不知道能不能用
第2個，Paul Caton的cCallFunc2.cls，支持的調(diào)用約定stdcall、cdecl、fastcall
'**********************************************************************************'** cCallFunc2.cls - cCallFunc with added fastcall support, call by address and'** additional return types'**'** Universal dll function/sub calling class'** cdecl/stdcall/fastcall calling convention'** Call by ordinal, name or address'** Module (.bas) callbacks for cdecl.'** Object (.cls/.frm/.ctl) callbacks for cdecl/stdcall'** Support for multiple callbacks.'** Support for multiple cCallFunc2 instances'** Support unicode path\module names'**'** If you wish to do crazy stuff like CallFunc with callbacks inside a callback'** then the best solution is to make a copy of the class, eg cCallFunc1.cls, and'** use an instance of that where needed.'**'** Calling conventions:'** stdcall: parameters right to left, called routine adjusts the stack'** cdecl: parameters right to left, caller adjusts the stack'** fastcall: first parameter, if present, in the ecx register'** second parameter, if present, in the edx register'** any other parameters are pushed to the stack'** called routine adjusts the stack'** N.B. fastcall isn't standardised, differing conventions exist.'** This class supports the Microsoft/GCC implementation.'**'** paul_caton@hotmail.com'**'** 20031029 First cut....................................................... v1.00'** 20071129 Now using virtual memory to fix a DEP issue..................... v1.01'** 20071130 Hacked from cCDECL, now supports stdcall and ordinals........... v1.02'** 20071201 Added support for callback objects.............................. v1.03'** 20071202 Unicode support for paths\modules where available............... v1.04'** 20071213 Forked from cCallFunc.cls'** Added support for fastcall calling convention'** Added CallPointer'** Changed the interface to be more property like.................. v1.05'** 20080212 Support Byte, Integer, Long, Single and Double return types..... v1.06'** 20080311 Added IsValidDll and IsValidMethod'** Parameter block made global'** Eliminated MAX_ARG, VB has a limit of 60 parameters'** Various optimizations........................................... v1.07'**********************************************************************************Option Explicit'API declarationsPrivate Declare Function FreeLibrary Lib 'kernel32' (ByVal hLibModule As Long) As LongPrivate Declare Function GetDesktopWindow Lib 'user32' () As LongPrivate Declare Function GetLastError Lib 'kernel32' () As LongPrivate Declare Function GetProcByName Lib 'kernel32' Alias 'GetProcAddress' (ByVal hModule As Long, ByVal lpProcName As String) As LongPrivate Declare Function GetProcByOrdinal Lib 'kernel32' Alias 'GetProcAddress' (ByVal hModule As Long, ByVal nOrdinal As Long) As LongPrivate Declare Function IsBadCodePtr Lib 'kernel32' (ByVal lpfn As Long) As LongPrivate Declare Function IsWindowUnicode Lib 'user32' (ByVal hWnd As Long) As LongPrivate Declare Function LoadLibraryA Lib 'kernel32' (ByVal lpLibFileName As String) As LongPrivate Declare Function LoadLibraryW Lib 'kernel32' (ByVal lpLibFileName As Long) As LongPrivate Declare Function VirtualAlloc Lib 'kernel32' (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As LongPrivate Declare Function VirtualFree Lib 'kernel32' (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As LongPrivate 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 callbackEnd 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 valueEnd 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 parametersEnd Type ' 'Private m_FastCall As Boolean 'FastCall private property valuePrivate m_LastError As Long 'LastError private property value Private bUnicode As Boolean 'Unicode flag 'Private vCode As Long 'Pointer to the machine-code thunksPrivate vTable As Long 'Class vTable addressPrivate nAddrPb As Long 'Address of the parameter blockPrivate hModule As Long 'Current/last-used dll handlePrivate strLastDLL As String 'Current/last-used dll namePrivate strLastFunc As String 'Current/last-used function/sub namePrivate 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 codeEnd 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 codeEnd 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 callbacksPublic 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 Err.Raise vbObjectError 2, SRC & 'CallbackCdecl', 'Invalid parameter' 'Raise error if running compiled End If ' ' CallbackCdecl = vCode 128 ((nIndex - 1) * 64) 'Address of the callback wrapper. Pass this return value as the callback address parameter of the cdecl function ' PutMem8 CallbackCdecl 0, 465203369712025.6232@ 'Callback wrapper machine code PutMem8 CallbackCdecl 8, -140418483381718.8339@ ' PutMem8 CallbackCdecl 16, -801546908679710.9163@ ' ' PutMem4 CallbackCdecl 10, nModFuncAddr - CallbackCdecl - (10 4) 'Patch the code to call the vb bas module callback function PutMem1 CallbackCdecl 16, nParams * 4 'Patch the code to apply the necessary stack adjustmentEnd Function ' ''CallbackObj: return a wrapper address for an object callback from a cdecl or stdcall function'' objType - Callback object type' objCallback - The callback object' nParams - The number of parameters that will be passed to the object callback function' nOrdinal - Callback ordinal. 1 = last private function in the callback object, 2 = second last private function in the callback object, etc' bCDECL - Specifes whether the callback calling function is cdecl or stdcall' nIndex - Allow for multiple simultaneous callbacksPublic Function CallbackObj(ByVal objType As eObjType, _ ByRef objCallback As Object, _ ByVal nParams As Long, _ Optional ByVal nOrdinal As Long = 1, _ Optional ByVal bCDECL As Boolean = False, _ Optional ByVal nIndex As Long = 1) As Long Dim o As Long 'Object pointer Dim i As Long 'vTable entry counter Dim j As Long 'vTable address Dim n As Long 'Method pointer Dim b As Byte 'First method byte Dim m As Byte 'Known good first method byte ' If nIndex < 1 Or nIndex > 60 Or nParams > 60 Then 'Parameter sanity checks Debug.Assert False 'Halt if running under the VB IDE Err.Raise vbObjectError 3, SRC & 'CallbackObj', 'Invalid parameter' 'Raise error if running compiled End If ' ' o = ObjPtr(objCallback) 'Get the callback object's address GetMem4 o, j 'Get the address of the callback object's vTable j = j objType 'Increment to the the first user entry for this callback object type GetMem4 j, n 'Get the method pointer GetMem1 n, m 'Get the first method byte... &H33 if pseudo-code, &HE9 if native j = j 4 'Bump to the next vtable entry ' For i = 1 To 511 'Loop through a 'sane' number of vtable entries GetMem4 j, n 'Get the method pointer ' If IsBadCodePtr(n) Then 'If the method pointer is an invalid code address GoTo vTableEnd 'We've reached the end of the vTable, exit the for loop End If ' ' GetMem1 n, b 'Get the first method byte ' If b <> m Then 'If the method byte doesn't matche the known good value GoTo vTableEnd 'We've reached the end of the vTable, exit the for loop End If ' ' j = j 4 'Bump to the next vTable entry Next i 'Bump counter Debug.Assert False 'Halt if running under the VB IDE Err.Raise vbObjectError 4, SRC & 'CallbackObj', 'Ordinal not found' 'Raise error if running compiled 'vTableEnd: 'We've hit the end of the vTable GetMem4 j - (nOrdinal * 4), n 'Get the method pointer for the specified ordinal ' CallbackObj = vCode 128 ((nIndex - 1) * 64) 'Address of the callback wrapper. Pass this return value as the callback address parameter ' PutMem8 CallbackObj 0, 648518346342877.6073@ 'Callback wrapper machine code PutMem8 CallbackObj 8, 9425443492.7235@ ' PutMem8 CallbackObj 16, -29652486425477.8624@ ' PutMem8 CallbackObj 24, 614907631944580.0296@ ' PutMem8 CallbackObj 32, -444355163233240.1323@ ' PutMem4 CallbackObj 40, &H90900055 ' ' PutMem1 CallbackObj &HD, nParams 'Patch the number of params PutMem4 CallbackObj &H19, o 'Patch the callback object PutMem4 CallbackObj &H1E, n - CallbackObj - (&H1E 4) 'Patch the callback call address PutMem1 CallbackObj &H28, IIf(bCDECL, 0, nParams * 4) 'Patch the stack correctionEnd Function ' Public Property Get FastCall() As Boolean 'Get FastCall flag FastCall = m_FastCall 'End Property ' 'Public Property Let FastCall(ByVal bValue As Boolean) 'Let Fastcall flag m_FastCall = bValue ' PutMem2 vCode &H11, IIf(m_FastCall, &H34EB, &H9090) 'Patch the code as per FastCall statusEnd Property ' 'IsValidDll - return whether the passed dll [path\]name is valid'' strDLL - [path\]name of the DLLPublic Function IsValidDll(ByRef strDll As String) ' 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 Then 'If the library loaded okay FreeLibrary hMod 'Free the library IsValidDll = True 'Indicate success End If 'End Function ''IsValidMethod - return whether the passed dll [path\]name / method name is valid'' strDLL - [path\]name of the DLL' strFunc - Name of the function or it's ordinal value preceded by a '#' eg. '#2'Public Function IsValidMethod(ByRef strDll As String, _ ByRef strFunc As String) ' 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 Then 'If the library loaded okay Dim nFuncAddr As Long 'Function address ' If Asc(strFunc) = 35 Then 'If '#...' eg '#2', ordinal 2 nFuncAddr = GetProcByOrdinal(hModule, CLng(Mid$(strFunc, 2))) 'Get the address of the function by ordinal Else ' nFuncAddr = GetProcByName(hModule, strFunc) 'Get the address of the function by name End If ' ' If nFuncAddr Then 'If the function was found in the module IsValidMethod = True 'Indicate success End If ' ' FreeLibrary hMod 'Free the library End If 'End Function 'Public Property Get LastError() As Long 'Get last error LastError = m_LastError 'End Property ' 'CallCommon: common CallFunc/CallPointer code'' RetType - Function return typePrivate Function CallCommon(ByVal RetType As eReturnType) As Variant PutMem1 vCode &H27, RetType 'Patch the return type jump ' SetLastError 0 'Clear the error code ' 'N.B. we patch the vTable on each call because there could be multiple 'instances of this class. Multiple instances share the same code... 'and would otherwise share the vCode of the last created instance. 'So we re-patch the vTable on each call to ensure the entry is hooked 'to the instance's vCode Select Case RetType 'Select on return type Case eReturnType.retByte 'Return a Byte PutMem4 vTable (19 * 4), vCode 'Patch the z_CallFunc_i08 entry to point to vCode CallCommon = z_CallFunc_i08(nAddrPb) 'Call ' Case eReturnType.retInteger 'Return an Integer PutMem4 vTable (20 * 4), vCode 'Patch the z_CallFunc_i16 entry to point to vCode CallCommon = z_CallFunc_i16(nAddrPb) 'Call ' Case eReturnType.retLong 'Return a Long PutMem4 vTable (21 * 4), vCode 'Patch the z_CallFunc_i32 entry to point to vCode CallCommon = z_CallFunc_i32(nAddrPb) 'Long ' Case eReturnType.retInt64 'Return 64bits (e.g. Currency) PutMem4 vTable (22 * 4), vCode 'Patch the z_CallFunc_i64 entry to point to vCode CallCommon = z_CallFunc_i64(nAddrPb) 'Call ' Case eReturnType.retSingle 'Return a Single PutMem4 vTable (23 * 4), vCode 'Patch the z_CallFunc_Sng entry to point to vCode CallCommon = z_CallFunc_Sng(nAddrPb) 'Call ' Case eReturnType.retDouble 'Return a Double PutMem4 vTable (24 * 4), vCode 'Patch the z_CallFunc_Dbl entry to point to vCode CallCommon = z_CallFunc_Dbl(nAddrPb) 'Call ' Case eReturnType.retSub 'Subroutine, no return value PutMem4 vTable (25 * 4), vCode 'Patch the z_CallFunc_Sub entry to point to vCode Call z_CallFunc_Sub(nAddrPb) 'Call Case Else 'Undefined return type Debug.Assert False 'Halt if running under the VB IDE Err.Raise vbObjectError 5, SRC & 'CallCommon', 'Unknown return type' 'Raise error if running compiled End Select ' ' m_LastError = GetLastError() 'Get the error codeEnd Function'Class_Initialize: initialize the cCallFunc2 instancePrivate Sub Class_Initialize() ' vCode = VirtualAlloc(0, &H1000&, &H1000&, &H40&) 'Allocate 4k of read/write/executable memory ' PutMem8 vCode 0, 695618785647368.6248@ 'Universal function caller machine code PutMem8 vCode 8, -208726556020175.3831@ ' PutMem8 vCode 16, -29652486425143.4233@ ' PutMem8 vCode 24, 614902794093417.828@ ' PutMem8 vCode 32, 193965741455568.6229@ ' PutMem8 vCode 40, -151277692825560.6392@ ' PutMem8 vCode 48, -857442152266638.7183@ ' PutMem8 vCode 56, 21029022751752.3025@ ' PutMem8 vCode 64, -7203916540378.4739@ ' PutMem8 vCode 72, -61276775362635.1564@ ' PutMem8 vCode 80, -454553025687766.4117@ ' ' GetMem4 ObjPtr(Me), vTable 'Get the address of the class vTable ' If GetProcByName(LoadLibraryA('user32'), 'IsWindowUnicode') Then 'Is IsWindowUnicode present bUnicode = IsWindowUnicode(GetDesktopWindow()) 'Determine whether we'll use the unicode version of LoadLibrary End If ' ' FastCall = False 'Default to non-Fastcall nAddrPb = VarPtr(pb) 'Address of the parameter blockEnd Sub ' ''Class_Terminate: cleanup the cCallFunc2 instancePrivate Sub Class_Terminate() ' If hModule <> 0 Then 'If a module is loaded FreeLibrary hModule 'Free the loaded module End If ' ' VirtualFree vCode, 0, &H8000& 'Free the allocated memoryEnd Sub '**********************************************************************************************************' These following function's vTable method pointers are patched to point to vCode in CallFunc & CallPointer' Note: these functions must be private and cannot be moved within this source file.'**********************************************************************************************************'z_CallFunc_i08: return BytePrivate Function z_CallFunc_i08(ByVal nParmAddr As Long) As Byte ' Debug.Assert False 'Halt if running under the VB IDEEnd Function ''z_CallFunc_i16: return Integer'' nParmAddr - address of the parameter blockPrivate Function z_CallFunc_i16(ByVal nParmAddr As Long) As Integer ' Debug.Assert False 'Halt if running under the VB IDEEnd Function ''z_CallFunc_i32: return Long'' nParmAddr - address of the parameter blockPrivate Function z_CallFunc_i32(ByVal nParmAddr As Long) As Long ' Debug.Assert False 'Halt if running under the VB IDEEnd Function ''z_CallFunc_i64: return int64'' nParmAddr - address of the parameter blockPrivate Function z_CallFunc_i64(ByVal nParmAddr As Long) As Currency ' Debug.Assert False 'Halt if running under the VB IDEEnd Function'z_CallFunc_Sng: return Single'' nParmAddr - address of the parameter blockPrivate Function z_CallFunc_Sng(ByVal nParmAddr As Long) As Single ' Debug.Assert False 'Halt if running under the VB IDEEnd Function ''z_CallFunc_Dbl: return Double'' nParmAddr - address of the parameter blockPrivate Function z_CallFunc_Dbl(ByVal nParmAddr As Long) As Double ' Debug.Assert False 'Halt if running under the VB IDEEnd Function ''z_CallFunc_Sub: no return value'' nParmAddr - address of the parameter blockPrivate Sub z_CallFunc_Sub(ByVal nParmAddr As Long) ' Debug.Assert False 'Halt if running under the VB IDEEnd Sub其他的應(yīng)用也有很多，但是這兩個類最強(qiáng)大，最穩(wěn)健。
