x64 上类方法崩溃的地址

Question

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, 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

假设一个

Class1

类有一个

Name

方法，我可以像这样使用上面的：

Debug.Print GetAddressOfClassMethod(New Class1, "Name")

该方法在 x32 上始终运行良好，并且大多数时候在 x64 上运行良好。问题是有时它会导致 x64 上崩溃。崩溃仅在

ITypeInfo_AddressOfMember

调用之后发生。

IDispatch_GetTypeInfo

永远不会导致崩溃。

我没有在这里发布代码，但我也调用了 ITypeInfo 接口甚至 ITypeComp 接口的其他方法，但我没有崩溃。

我做错了什么吗？对于为什么会发生崩溃有什么想法吗？

Answer 1

显然有两个问题。第一个很容易修复，而第二个则无法修复。

第 1 期

iTypeInfo

实例的引用计数没有正确减少。

这可以通过将

iTypeInfoPtr

替换为

Dim iTypeInfo As IUnknown

来解决，然后显然更新

IDispatch_GetTypeInfo

的方法定义以接收

ByRef ppTInfo As IUnknown

。另外，

DispGetIDsOfNames iTypeInfoPtr...

将替换为

DispGetIDsOfNames ObjPtr(iTypeInfo)...

第2期

当在

AddressOfMember

接口上调用

ITypeInfo

时，这实际上会覆盖我们试图获取地址的方法的部分汇编代码，即由

methodName

标识的方法。仅当修改类代码（包括重新导入模块）或重新启动主机应用程序时，程序集才会重置。