问题
The AddressOf operator works only with methods inside standard .bas modules. I am using the following code to retrieve the addresses of class methods:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As tagCALLCONV, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As LongPtr, ByRef pvargResult As Variant) As Long
Private Declare PtrSafe Function DispGetIDsOfNames Lib "oleaut32.dll" (ByVal ptinfo As LongPtr, ByVal rgszNames As LongPtr, ByVal cNames As Long, ByVal rgDispId As LongPtr) As Long
#Else
Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As tagCALLCONV, ByVal vtReturn As Integer, ByVal cActuals As Long, ByRef prgvt As Integer, ByRef prgpvarg As Long, ByRef pvargResult As Variant) As Long
Private Declare Function DispGetIDsOfNames Lib "oleaut32.dll" (ByVal ptinfo As Long, ByVal rgszNames As Long, ByVal cNames As Long, ByVal rgDispId As Long) As Long
#End If
Private Type INVOKE_ARGS
args() As Variant
argsVT() As Integer
#If VBA7 Then
argsPtrs() As LongPtr
#Else
argsPtrs() As Long
#End If
argsCount As Long
End Type
#If Win64 Then
Private Const PTR_SIZE As Long = 8
#Else
Private Const PTR_SIZE As Long = 4
#End If
'IDispatch derives from the IUnknown interface
Private Enum IDispatchVtblOffset
oQueryInterface = PTR_SIZE * 0 'IUnknown
oAddRef = PTR_SIZE * 1 'IUnknown
oRelease = PTR_SIZE * 2 'IUnknown
oGetTypeInfoCount = PTR_SIZE * 3 'IDispatch
oGetTypeInfo = PTR_SIZE * 4 'IDispatch
oGetIDsOfNames = PTR_SIZE * 5 'IDispatch
oInvoke = PTR_SIZE * 6 'IDispatch
End Enum
'ITypeInfo derives from the IUnknown interface
Private Enum ITypeInfoVtblOffset
oQueryInterface = PTR_SIZE * 0 'IUnknown
oAddRef = PTR_SIZE * 1 'IUnknown
oRelease = PTR_SIZE * 2 'IUnknown
oGetTypeAttr = PTR_SIZE * 3
oGetTypeComp = PTR_SIZE * 4
oGetFuncDesc = PTR_SIZE * 5
oGetVarDesc = PTR_SIZE * 6
oGetNames = PTR_SIZE * 7
oGetRefTypeOfImplType = PTR_SIZE * 8
oGetImplTypeFlags = PTR_SIZE * 9
oGetIDsOfNames = PTR_SIZE * 10
oInvoke = PTR_SIZE * 11
oGetDocumentation = PTR_SIZE * 12
oGetDllEntry = PTR_SIZE * 13
oGetRefTypeInfo = PTR_SIZE * 14
oAddressOfMember = PTR_SIZE * 15
oCreateInstance = PTR_SIZE * 16
oGetMops = PTR_SIZE * 17
oGetContainingTypeLib = PTR_SIZE * 18
oReleaseTypeAttr = PTR_SIZE * 19
oReleaseFuncDesc = PTR_SIZE * 20
oReleaseVarDesc = PTR_SIZE * 21
End Enum
Private Enum tagINVOKEKIND
INVOKE_FUNC = &H1
INVOKE_PROPERTYGET = &H2
INVOKE_PROPERTYPUT = &H4
INVOKE_PROPERTYPUTREF = &H8
End Enum
'Calling Conventions
Private Enum tagCALLCONV
CC_FASTCALL = 0
CC_CDECL = 1
CC_MSCPASCAL = 2
CC_PASCAL = CC_MSCPASCAL
CC_MACPASCAL = 3
CC_STDCALL = 4
CC_FPFASTCALL = 5
CC_SYSCALL = 6
CC_MPWCDECL = 7
CC_MPWPASCAL = 8
CC_MAX = 9
End Enum
Const S_OK As Long = 0
#If VBA7 Then
Public Function GetAddressOfClassMethod(ByVal classInstance As Object, ByVal methodName As String) As LongPtr
#Else
Public Function GetAddressOfClassMethod(ByVal classInstance As Object, ByVal methodName As String) As Long
#End If
#If VBA7 Then
Dim iDispatchPtr As LongPtr
Dim iTypeInfoPtr As LongPtr
#Else
Dim iDispatchPtr As Long
Dim iTypeInfoPtr As Long
#End If
Dim localeID As Long 'Not really needed. Could pass 0 instead
'
'Get a pointer to the IDispatch interface
iDispatchPtr = ObjPtr(GetDefaultInterface(classInstance))
'
'Get a pointer to the ITypeInfo interface
localeID = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
IDispatch_GetTypeInfo iDispatchPtr, 0, localeID, iTypeInfoPtr
'
Dim arrNames(0 To 0) As String: arrNames(0) = methodName
Dim arrIDs(0 To 0) As Long
'
'Get ID of required member
DispGetIDsOfNames iTypeInfoPtr, VarPtr(arrNames(0)), 1, VarPtr(arrIDs(0))
'
'Get address of member
ITypeInfo_AddressOfMember iTypeInfoPtr, arrIDs(0), INVOKE_FUNC, GetAddressOfClassMethod
End Function
'*******************************************************************************
'Returns the default interface for an object
'All VB intefaces are dual interfaces meaning all interfaces are derived from
' IDispatch which in turn is derived from IUnknown. In VB the Object datatype
' stands for the IDispatch interface.
'Casting from a custom interface (derived only from IUnknown) to IDispatch
' forces a call to QueryInterface for the IDispatch interface (which knows
' about the default interface)
'*******************************************************************************
Private Function GetDefaultInterface(obj As IUnknown) As Object
Set GetDefaultInterface = obj
End Function
'*******************************************************************************
'IDispatch::GetTypeInfo
'*******************************************************************************
#If VBA7 Then
Private Function IDispatch_GetTypeInfo(ByVal iDispatchPtr As LongPtr, ByVal iTInfo As Long, ByVal lcid As Long, ByRef ppTInfo As LongPtr) As Long
#Else
Private Function IDispatch_GetTypeInfo(ByVal iDispatchPtr As Long, ByVal iTInfo As Long, ByVal lcid As Long, ByRef ppTInfo As Long) As Long
#End If
Dim hResult As Long
'
With CreateInvokeArgs(iTInfo, lcid, VarPtr(ppTInfo))
hResult = DispCallFunc(iDispatchPtr, IDispatchVtblOffset.oGetTypeInfo, CC_STDCALL, vbLong, .argsCount, .argsVT(0), .argsPtrs(0), IDispatch_GetTypeInfo)
End With
If hResult <> S_OK Then Err.Raise hResult, "IDispatch_GetTypeInfo"
End Function
'*******************************************************************************
'ITypeInfo::AddressOfMember
'*******************************************************************************
#If VBA7 Then
Private Function ITypeInfo_AddressOfMember(ByVal iTypeInfoPtr As LongPtr, ByVal memid As Long, ByVal invKind As tagINVOKEKIND, ByRef ppv As LongPtr) As Long
#Else
Private Function ITypeInfo_AddressOfMember(ByVal iTypeInfoPtr As Long, ByVal memid As Long, ByVal invKind As tagINVOKEKIND, ByRef ppv As Long) As Long
#End If
Dim hResult As Long
'
With CreateInvokeArgs(memid, invKind, VarPtr(ppv))
hResult = DispCallFunc(iTypeInfoPtr, ITypeInfoVtblOffset.oAddressOfMember, CC_STDCALL, vbLong, .argsCount, .argsVT(0), .argsPtrs(0), ITypeInfo_AddressOfMember)
End With
If hResult <> S_OK Then Err.Raise hResult, "ITypeInfo_AddressOfMember"
End Function
'*******************************************************************************
'Helper function that creates the necessary arrays to use with DispCallFunc
'Passing arguments:
' - ByVal: pass the arg
' - ByRef: pass VarPtr(arg)
'*******************************************************************************
Private Function CreateInvokeArgs(ParamArray args() As Variant) As INVOKE_ARGS
With CreateInvokeArgs
.argsCount = UBound(args) + 1 'ParamArray is always 0-based (LBound)
If .argsCount = 0 Then
ReDim .argsVT(0 To 0)
ReDim .argsPtrs(0 To 0)
Exit Function
End If
'
.args = args 'Avoid ByRef issues by making a copy
ReDim .argsVT(0 To .argsCount - 1)
ReDim .argsPtrs(0 To .argsCount - 1)
Dim i As Long
'
'For Each is not used because it does copies of the values inside the
' array and we need the actual addresses of the values (ByRef)
For i = 0 To .argsCount - 1
.argsVT(i) = VarType(.args(i))
.argsPtrs(i) = VarPtr(.args(i))
Next i
End With
End Function
Assuming a Class1 class that has a Name method, I could use the above like this:
Debug.Print GetAddressOfClassMethod(New Class1, "Name")
The approach always works fine on x32 and most of the time on x64. The problem is that sometimes it causes a crash on x64. The crash happens only after the ITypeInfo_AddressOfMember call. The IDispatch_GetTypeInfo never causes a crash.
I haven't posted the code here, but I also call other methods of the ITypeInfo interface and even of the ITypeComp interface but I don't get crashes.
Am I doing something wrong? Any ideas of why the crashes occur?
来源：https://stackoverflow.com/questions/65507735/address-of-class-method-crash-on-x64