如何解决x64 上 Class 方法崩溃的地址
AddressOf 运算符仅适用于标准 .bas 模块中的方法。我正在使用以下代码来检索类方法的地址：
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,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 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,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,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,ByRef ppv As Long) As Long
#End If
Dim hResult As Long
'
With CreateInvokeArgs(memid,invKind,VarPtr(ppv))
hResult = DispCallFunc(iTypeInfoPtr,ITypeInfoVtblOffset.oAddressOfMember,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
假设一个具有 Class1 方法的 Name 类，我可以像这样使用上面的：
Debug.Print GetAddressOfClassMethod(New Class1,"Name")
该方法在 x32 上始终运行良好，大部分时间在 x64 上运行良好。问题是有时它会导致 x64 崩溃。只有在调用 ITypeInfo_AddressOfMember 之后才会发生崩溃。 IDispatch_GetTypeInfo 永远不会导致崩溃。
我没有在这里发布代码，但我也调用了 ITypeInfo 接口甚至 ITypeComp 接口的其他方法，但我没有崩溃。
我做错了吗？关于崩溃发生的原因有什么想法吗？
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
