總共就兩個部分，第一部分說幾個聲明API并使用的技巧，第二部分簡單講一下怎么動態調用DLL
玩API的人看到前面的描述肯定會心里MMP，廢話少說，看內容。
1、相對路徑聲明
這個最好理解
普通的API聲明長這樣：
Declare Function LZ4_versionNumber Lib "liblz4" Alias "_LZ4_versionNumber@0" () As Long
下面是其FullPath版本的聲明：
Declare Function LZ4_versionNumber Lib "c:\liblz4.dll" Alias "_LZ4_versionNumber@0" () As Long
下面是其相對路徑版本的聲明：
Declare Function LZ4_versionNumber Lib "..\Plugins\liblz4" Alias "_LZ4_versionNumber@0" () As Long
這特么怎么這么復雜呢，這三種都可以？下面也就簡單一解釋，不做深入研究，各位看官也就看看就好，能記住就記住。
先說FullPath版本，這是最低級的使用方法，一般人不會這么用；還有一種方法也可以指定FullPath，那就是使用manifest，manifest是個好東西，這個以后再扒。
然后是普通的API和相對路徑的API，這倆其實是一個原理：
對于VB6，怎么檢索DLL呢，當然是先檢索App.Path（1、不檢索子目錄；2、VBA里對應Application.Path）
然后再檢索環境變量目錄
很多人不知道怎么看環境變量，Win+R，cmd，輸入set，enter，就看到了所有環境變量
上述DLL靜態聲明，會在當前目錄和所有環境變量目錄，以相對路徑檢索DLL（如果多個路徑都檢索到，這個要應用檢索規則，這里也不扒了）
假設環境變量中有一個路徑：c:\xxx
那么API中的"..\Plugins\liblz4"和"liblz4"，就分別對應了路徑：
"c:\xxx\..\Plugins\liblz4.dll"和"c:\xxx\liblz4.dll"
上面".."的意思是指上一級目錄，也即
"c:\xxx\..\Plugins\liblz4.dll" = "c:\Plugins\liblz4.dll"
2、動態路徑
先說怎么用，聲明就跟普通聲明方式一樣：
Declare Function LZ4_versionNumber Lib "liblz4" Alias "_LZ4_versionNumber@0" () As Long
但是，如果這時候在環境變量目錄下都沒有這個dll的話
在使用這個dll之前，我們可以用LoadLibrary這個API來加載一下dll，就可以調用"LZ4_versionNumber"了
Declare聲明函數時，是聲明函數指針，并指明入口點，VB6會通過內部函數DllFunctionCall（該函數會調用LoadLibraryA）來調用外部API
如果Declare時，在所有路徑都找不到DLL，而這時候，你主動使用LoadLibrary加載了該DLL
這時候，就解決了加載DLL的問題，相當于運行時重定向DLL
3、修改環境變量
VB6程序在加載時，會優先加載App.Path
然后會加載進程環境變量，進程環境變量
這里相關的API有5個，這里用到的就前2個：
Declare Function GetEnvironmentVariableA Lib "kernel32" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long '單個獲取進程環境變量 Declare Function SetEnvironmentVariableA Lib "kernel32" (ByVal lpName As String, ByVal lpValue As String) As Long '單個設置進程環境變量 Declare Function GetEnvironmentStringsA Lib "kernel32" () As Long '獲取當前進程所有環境變量 Public Declare Function SetEnvironmentStringsA Lib "kernel32" (ByVal lpszEnvironmentBlock As Long) As Long '設置當前進程所有環境變量 Public Declare Function FreeEnvironmentStringsA Lib "kernel32" (ByVal lpszEnvironmentBlock As Long) As Long '清理臨時指針
然后加環境變量就是這樣操作：
Dim lngRet As Long Dim strDest As String Dim arr() As String, i As Long Dim boolIn As Boolean '路徑是否在環境變量中 Const MAX_BUFFER = 9000& strDest = String$(MAX_BUFFER, Chr(0)) GetEnvironmentVariableA "Path", strDest, MAX_BUFFER + 1 '獲取當前進程的Path環境變量 lngRet = InStr(strDest, Chr(0)) strDest = Left(strDest, lngRet - 1) '清掉緩存字符 arr = Split(strDest, ";") '判斷路徑是否已經在環境變量中 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 '設置當前進程的Path環境變量，加在最前面 End If
這樣設置之后，檢測DLL的時候，就多了一個自定義設置的strDllPath路徑了
以下內容多且復雜，初學者直接跳過，由于這里對外鏈卡得比較嚴，我就只敢貼代碼。
所以，需要探討的，在評論里交流
很多時候，開發者不想寫那么多Declare，就論這個問題，其實有兩個解決方案。
一個是使用tlb，現在有很多包含win32api的tlb文件，tlb文件制作簡單，在編寫代碼時引用到工程里，發布程序時不需要附帶tlb文件
還有一種方案就是動態調用：
說起來方法其實很簡單
第1步：LoadLibrary，加載DLL模塊到內存
第2步：GetProcAddress，獲取DLL里的API函數指針
第3步：CallWindowProc或者DispCallFunc，調用函數
第4步：FreeLibrary，用完了釋放函數
但是如果真的要自己去研究，而且要支持多種調用約定的話，就比較麻煩了。
像CallWindowProc，在不寫匯編代碼的情況下，只能支撐有4個參數的API
這里當然不會講怎么寫匯編代碼，所以這里推薦幾個已有的輪子：
不用知其所以然，只用知道怎么用就好。
第1個：DispCallFunc方案
vbforums論壇高人Lavolpe寫的類cUniversalDLLCalls.cls，理論上支持9種調用約定
' 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
這個類強大的不行，使用起來也極其簡單：
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Command1_Click()
Dim c As cUniversalDLLCalls
Dim sBuffer As String, lLen As Long
Set c = New cUniversalDLLCalls
'/// 1st four examples show 2 ways of calling an ANSI function & 2 ways of calling a Unicode function
' example of calling ANSI function, passing strings ByRef
Debug.Print "ANSI string parameters, ByRef..."
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextLengthA", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd)
sBuffer = String$(lLen, vbNullChar)
' STR_ANSI + string variable name = ByRef
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextA", STR_ANSI, CR_LONG, CC_STDCALL, Me.hWnd, sBuffer, lLen + 1&)
Debug.Print vbTab; "form caption is: "; Left$(StrConv(sBuffer, vbUnicode), lLen); "<<<"
' example of calling ANSI function, passing strings ByVal
Debug.Print "ANSI string parameters, ByVal..."
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextLengthA", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd)
sBuffer = String$(lLen, vbNullChar)
' STR_NONE + string variable name = ByVal. Note: Only use ANSI ByRef if string sole purpose is a buffer
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextA", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd, StrPtr(sBuffer), lLen + 1&)
Debug.Print vbTab; "form caption is: "; Left$(StrConv(sBuffer, vbUnicode), lLen); "<<<"
' example of calling UNICODE function, passing strings ByRef
Debug.Print "Unicode string parameters, ByRef..."
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextLengthW", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd)
sBuffer = String$(lLen, vbNullChar)
' STR_UNICODE + string variable name = ByRef
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextW", STR_UNICODE, CR_LONG, CC_STDCALL, Me.hWnd, sBuffer, lLen + 1&)
Debug.Print vbTab; "form caption is: "; Left$(sBuffer, lLen); "<<<"
' example of calling UNICODE function, passing strings ByVal
Debug.Print "Unicode string parameters, ByVal..."
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextLengthW", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd)
sBuffer = String$(lLen, vbNullChar)
' STR_NONE + StrPtr(variable name) = ByVal
lLen = c.CallFunction_DLL("user32.dll", "GetWindowTextW", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd, StrPtr(sBuffer), lLen + 1&)
Debug.Print vbTab; "form caption is: "; Left$(sBuffer, lLen); "<<<"
'/// UDT/Array examples
' example of passing a structure
Dim tRect As RECT
Debug.Print "UDT/structure parameters, ByRef..."
Call c.CallFunction_DLL("user32.dll", "GetWindowRect", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd, VarPtr(tRect))
Debug.Print vbTab; "window position on screen: L"; CStr(tRect.Left); ".T"; CStr(tRect.Top); " R"; CStr(tRect.Right); ".B"; CStr(tRect.Bottom)
' the RECT structure is 16 bytes, we can use an array of Long if we like
Dim aRect(0 To 3) As Long
Debug.Print "Array parameters, ByRef..."
Call c.CallFunction_DLL("user32.dll", "GetWindowRect", STR_NONE, CR_LONG, CC_STDCALL, Me.hWnd, VarPtr(aRect(0)))
Debug.Print vbTab; "window position on screen: L"; CStr(aRect(0)); ".T"; CStr(aRect(1)); " R"; CStr(aRect(2)); ".B"; CStr(aRect(3))
'/// CDecl function call
Dim sFmt As String
sBuffer = String$(1024, vbNullChar)
sFmt = "P1=%s, P2=%d, P3=%.4f, P4=%s"
' unicode version of the function
Debug.Print "CDecl Unicode parameters, ByRef..."
lLen = c.CallFunction_DLL("msvcrt.dll", "swprintf", STR_UNICODE, CR_LONG, CC_CDECL, sBuffer, sFmt, "ABC", 123456, 1.23456, "xyz")
Debug.Print vbTab; "printf: "; Left$(sBuffer, lLen)
' ANSI version of the function, same parameters
Debug.Print "CDecl ANSI parameters, ByRef..."
lLen = c.CallFunction_DLL("msvcrt.dll", "sprintf", STR_ANSI, CR_LONG, CC_CDECL, sBuffer, (sFmt), "ABC", 123456, 1.23456, "xyz")
Debug.Print vbTab; "printf: "; Left$(StrConv(sBuffer, vbUnicode), lLen)
''/// COM object call
' All VB objects inherit from IUnknown (which has 3 virtual functions)
' IPicture inherits from IUnknown and has several virtual functions
' This example will call the 1st function which is now the 4th function, preceeded by IUnknown's 3 functions
' NOTE: simple example. We can declare a IPicture interface via VB, but many interfaces are not exposed,
' and this example indicates how to get a pointer to the interface & call functions from that pointer.
' But just like any function, you must research to determine the VTable order & function parameter
' requirements. Do not assume that some page describing the interface functions lists the functions
' in VTable order. That assumption will lead to crashes.
Dim IID_IPicture As Long, aGUID(0 To 3) As Long, lPicHandle As Long
Const IUnknownQueryInterface As Long = 0& ' IUnknown vTable offset to Query implemented interfaces
Const IUnknownRelease As Long = 8& ' IUnkownn vTable offset to decrement reference count
Const IPictureGetHandle As Long = 12& ' 4th VTable offset from IUnknown
' GUID for IPicture {7BF80980-BF32-101A-8BBB-00AA00300CAB}
c.CallFunction_DLL "ole32.dll", "CLSIDFromString", STR_UNICODE, CR_LONG, CC_STDCALL, "{7BF80980-BF32-101A-8BBB-00AA00300CAB}", VarPtr(aGUID(0))
c.CallFunction_COM ObjPtr(Me.Icon), IUnknownQueryInterface, CR_LONG, CC_STDCALL, VarPtr(aGUID(0)), VarPtr(IID_IPicture)
If IID_IPicture <> 0& Then
' get the icon handle & then Release the IPicture interface. QueryInterface calls AddRef internally
c.CallFunction_COM IID_IPicture, 12&, CR_LONG, CC_STDCALL, VarPtr(lPicHandle)
c.CallFunction_COM IID_IPicture, IUnknownRelease, CR_LONG, CC_STDCALL
End If
Debug.Print "COM interface call example..."
Debug.Print vbTab; "Me.Icon.Handle = "; Me.Icon.Handle; " IPicture.GetHandle = "; lPicHandle
' The PointerToString methods are a courtesy
'/// simple example to return a string from a pointer
sFmt = "LaVolpe"
Debug.Print "PointerToStringA & PointerToStringW examples..."
sBuffer = c.PointerToStringW(StrPtr(sFmt)) ' unicode example
Debug.Print vbTab; sBuffer; "<<<"
sFmt = StrConv(sFmt, vbFromUnicode)
sBuffer = c.PointerToStringA(StrPtr(sFmt)) ' ANSI example
Debug.Print vbTab; sBuffer; "<<<"
End Sub
stdcall和cdecl的支持已經做進來了，其他的沒有給應用案例，不知道能不能用
第2個，Paul Caton的cCallFunc2.cls，支持的調用約定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 declarations
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
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 adjustment
End 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 callbacks
Public 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 correction
End 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 status
End Property '
'IsValidDll - return whether the passed dll [path\]name is valid
'
' strDLL - [path\]name of the DLL
Public 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 type
Private 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 code
End Function
'Class_Initialize: initialize the cCallFunc2 instance
Private 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 block
End Sub '
'
'Class_Terminate: cleanup the cCallFunc2 instance
Private 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 memory
End 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 Byte
Private Function z_CallFunc_i08(ByVal nParmAddr As Long) As Byte '
Debug.Assert False 'Halt if running under the VB IDE
End Function '
'z_CallFunc_i16: return Integer
'
' nParmAddr - address of the parameter block
Private Function z_CallFunc_i16(ByVal nParmAddr As Long) As Integer '
Debug.Assert False 'Halt if running under the VB IDE
End Function '
'z_CallFunc_i32: return Long
'
' nParmAddr - address of the parameter block
Private Function z_CallFunc_i32(ByVal nParmAddr As Long) As Long '
Debug.Assert False 'Halt if running under the VB IDE
End Function '
'z_CallFunc_i64: return int64
'
' nParmAddr - address of the parameter block
Private Function z_CallFunc_i64(ByVal nParmAddr As Long) As Currency '
Debug.Assert False 'Halt if running under the VB IDE
End Function
'z_CallFunc_Sng: return Single
'
' nParmAddr - address of the parameter block
Private Function z_CallFunc_Sng(ByVal nParmAddr As Long) As Single '
Debug.Assert False 'Halt if running under the VB IDE
End Function '
'z_CallFunc_Dbl: return Double
'
' nParmAddr - address of the parameter block
Private Function z_CallFunc_Dbl(ByVal nParmAddr As Long) As Double '
Debug.Assert False 'Halt if running under the VB IDE
End Function '
'z_CallFunc_Sub: no return value
'
' nParmAddr - address of the parameter block
Private Sub z_CallFunc_Sub(ByVal nParmAddr As Long) '
Debug.Assert False 'Halt if running under the VB IDE
End Sub
其他的應用也有很多，但是這兩個類最強大，最穩健。
VB/VBA更注重如何用，作為系統腳本更中！
在《VB/VBA為何不需要所謂的標準DLL？》中給大家伙解釋了什么是標準DLL，為何VB/VBA不需要這樣的標準DLL。簡單總結下，標準DLL就是導出了指定函數的DLL，方便直接通過函數指針的方式進行調用。在VB/VBA中呢，就是可以通過Declare機制進行聲明和使用。但VB/VBA通過COM接口，要遠比Declare方式高效靈活，所以VB/VBA不需要所謂的標準DLL。
Declare相關討論可以參考《VB/VBA的Win32API聲明中，不得不了解的真相》《來聊聊VB/VBA函數》《VB/VBA中Declare聲明API時，這樣用效率又會增加一點點哦！》...
但是VB/VBA是COM的語言，編譯的DLL天生就是ActiveXDLL，也即是說天然就會有4個標準的COM導出函數，那為何還在強調是否標準與否呢？網友一針見血地說，標準DLL才不是為了讓VB/VBA方便Declare呢，想想其他編程語言要怎么調用VB/VBA的DLL？這就是今天要跟大家分享的，『為何VB/VBA不需要標準DLL，其他語言也不需要VB/VBA的標準DLL?』。
《VB/VBA為何不需要所謂的標準DLL？》也解釋了利用COM接口，在VB/VBA的IDE中，通過對象+『.』，非常便捷，使用上也很高效。從使用Dll函數的角度，無論是Declare還是直接使用函數指針，這都是沒法比的。
Declare不僅需要自己寫聲明，而且會內建一套類導入表的機制。就為了避免用戶直接面對函數指針，可謂是繞了一大圈。要在VB/VBA中直接使用函數指針，方便是方便，但得懂如何用才行，不然也不會讓Declare處心積慮地隱藏它。
這顯然與VB/VBA的定位和用戶群，是不符的。但無論怎樣，最后大家都是奔向函數指針而去的，因為指令層面就認這個超級GOTO+行號(Call/跳+函數地址)。
前面也說了，ActiveXDLL會導出4個函數，這4個函數就是COM對象使用函數的關鍵，也同樣是奔著函數指針去的。事實上，其他語言使用DLL函數指針是通過導出/導入表，與COM對象使用成員函數的機制是一樣的，這便是VTable綁定。這是VB/VBA唯一可以和其他語言平起平坐講專業性的地方，不過很可惜，VB/VBA還是通過類和對象將其遮蓋得嚴嚴實實。
需要了解VTable相關知識點的朋友，請繼續關注后續文章，VB/VBA的很多高階用法都離不開這一機制，比如函數指針動態調用，處理C調約（調用C調約API，提供C調約回調函數），IDE和編譯均適用的嵌入匯編等。
VB/VBA的COM接口中的VTable綁定機制，不僅兼顧了源碼編寫上的便捷和高效（對應IDE的智能提示和自動補全），而且也同樣兼顧了代碼運行的高效率，與其他專業語言不相上下（比如C/C++）。所以，VB/VBA中確實是不需要所謂標準DLL的。
1、先問VB/VBA的先人BASIC是干什么的？
其實，一開始BASIC，就以教員的方式，盯著如何讓文科一類背景的人使用計算機，所以如何操作計算機便是后來VB的核心基因之一。這個使用當然不是專業程序員那般細膩的控制，而是在更粗糙的粒度上的操作體驗。早期的BASIC沒有現在的鼠標視窗環境，這種使用，大抵跟很多人心中的黑客風，是差不多的吧。
如果調整下字體和背景色，還以為是黑客在搞事！
要拿到現在，是不是會勸退很多人呢？但在那個年代，這已經很親民了，畢竟學生們不用刻意去負擔半導體專業知識也能讓機器跑起來。后來，微軟加入了鼠標驅動的視窗環境，BASIC再一次脫胎換骨為VB/VBA，以一夫當關萬夫莫開的氣勢，撐起了大家對Windows的好奇，微軟自然也贏得了小白們的選票，真正演繹了『得小白者得天下』的真理！
2、再問VB/VBA是什么？
如果說MS-DOS是微軟背靠IBM積累家底的量變階段，那后來的VB/VBA就是微軟翅膀硬了，與IBM分道揚鑣各奔前程的資本。以現在的計算機環境，是很難理解VB竟然這么牛叉的。相信不少上個世紀80/90年代過來的程序員，是很清楚當時編程的門檻有多高。
專業程序員，都是寶啊，可遇不可求的那種。突然來一個，拖拖拽拽，三五分鐘就可以弄個示例軟件出來的工具，那必然是爆炸性的。不僅僅因為可以在廣袤的普通百姓心里種下編程的種子，為后來的程序員職業的繁榮立下汗馬功勞。更因為微軟千方百計地通過VB，向廣大小白們演示著Windows的優越性。
要演示系統的優越特性，沒有方便之門怎么行。直到今天，仍然有不少老程序員認為，微軟為VB傾斜了太多的資源。甚至還有極端者認為，比爾-蓋茨只懂BASIC，而不惜改造C/C++規范，就只為VB能用上C/C++庫資源。雖然有點夸張，但對于VB/VBA而言，的確將系統的某些特性運用的爐火純青，這就是VB/VBA在Windows中扎根太深，而難以跨平臺的根本原因，同時也是Linux平臺上類BASIC語言難以超越VB/VBA，有其形而無其魂的原因所在。
后續會不斷分享VB/VBA是如何利用系統特性的，VB/VBA用戶又該如何使用這些特性來提升代碼的性能和編寫效率，歡迎關注哦！
VB/VBA一度是Windows功能的Demo工具，不僅有歷史的原因，更有歷史的機遇。一方面，當年BASIC的教學設計，就重在普適的人機交互，以BASIC起家的微軟，自然門兒清。因為說到底，再牛逼的技術和機器，也是要給人服務的。另一方面，背靠IBM的十余年間，BASIC不僅替微軟摸排了市場的真實需求（痛點），更為微軟培養了無數BASCI粉。所以，當微軟與將IBM分道揚鑣時，具有普適性（視窗+鼠標）的VB自然當仁不讓地挑起了大梁，并伴隨著Windows的不斷完善而得到改進。
其實，這是一個相互成就的過程，并非微軟一心偏袒VB。雖然，今天的VB/VBA確顯老舊，但不可否認VB/VBA一身武藝，都是實實在在的精華。這是不深入Windows和VB，就了解不到的真相。
《什么是腳本語言？為何VBA不算腳本語言？》便是VB的冰山一角，更多背景可閱讀《以史為鑒，編程語言，啟示錄之系統覺醒》《VB前傳，從教學到游戲，再到系統，似乎每步都是精心設計》等文章。
VB/VBA作為與系統相伴成長起來的可視化編程工具，是一個前可見古人，后不見來者的歷史遺產。筆者之所以，極力推薦那些沒有過多精力，但又想通過編程提升效率的職場人士學習VB/VBA，其實就是看中VB/VBA的這種系統功能的膠水能力。在Win上VB/VBA就是那個最強的膠水語言！
3、為何不需要VB/VBA的標準DLL？
弄懂了VB/VBA的背景，自然就好理解為何不需要VB/VBA來制造所謂標準DLL了。在前面說了，VB/VBA本身對標準DLL的需求并非不可或缺，大家責難VB/VBA無法輸出標準DLL，大抵是因為其他編程工具，用函數指針的方式來使用VB/VBA編譯的DLL函數時，不管用了！
這個原因，其實在前面的VTable關鍵字附近，已經回答了。不知道如何調用ActiveXDLL中的函數，純粹是不懂，而并非人家爛。更何況，VB/VBA在編譯時，可以導出函數。只是，筆者會認為VB/VBA的標準DLL，會和市場反應一樣，并沒有人需要。
作為系統特色的表演者，VB/VBA也只是個看菜下飯的家伙，眾物不過工具而已，拼湊才是她的本事。它保留了多種代碼執行模式，不僅可以作為命令行的終極宿主執行各種系統命令，也可以于碼海中隨意抽取逐句執行，更可以直接執行指定的機器指令。不僅面向過程，也面向對象，更有函數式。不僅用作腳本，自動化，輕代碼化，當好護花使者，也可以編譯獨立行走江湖。不僅有編譯器語句打底，更有內置函數、系統和非系統API的裝扮。不僅與所謂標準DLL耍朋友，更是與COM拜把子。但所有這些，都只不過保留了一種能力上的接口，并未過多修飾。
用過的人，都知道VB/VBA在語句和內置函數上表現出來的封裝性并不高，它甚至都無法做到IDE的代碼折疊。一方面VB/VBA容易使用，容易上手，另一方面VB/VBA又很難精通。所以，她注定無法在代碼的流水線上留下自己的職位。
同作為功能的膠水，自然可以拿大家公認的Python來做類比。Python的強大，是因為豐富的庫資源，和她的撮合能力。但是，有幾個直接拿Python去干輪子的？道理是一樣的，VB/VBA擅長的，是使用系統里面各色資源，而非制造資源。VB/VBA在使用上的安全性、包容性無一不是圍繞使用資源而展開的，在VB/VBA的編譯器（解釋器）里充斥著大量讓專業人士嗤之以鼻的模板化的指令，就意味著VB/VBA生而不為輪子，她是輪子的用戶！
道理還是一樣的，這貨制造的輪子，性能不咋地啊！雖然可以通過手術方式進行二次加工，讓其更優化，但已經脫離VB/VBA的高使用效率和低危錯誤的立身之本了。所以，其他語言不需要VB/VBA的標準DLL，VB/VBA也不打算提供標準DLL，就這么簡單！
歡迎關注BtOfficer（收藏、點贊、關注+轉發）,更多精彩仍在繼續哦（專欄文章將更系統，更全面，但需要閣下支持哦），有嚴肅的技術，也有輕松的嘮嗑，期待你的加入！