x64环境下获取VBA类方法地址时偶现崩溃问题排查

首先，你的思路是对的——利用IDispatch和ITypeInfo接口绕开AddressOf只能用于标准模块的限制，这个方案在32位环境下稳定运行，但64位环境偶尔崩溃的问题，大概率和接口资源管理、内存访问的细节有关，咱们一步步分析：

问题背景回顾 #

你实现了GetAddressOfClassMethod函数来获取类方法地址，测试时32位环境全程正常，64位环境多数时候没问题，但偶尔在ITypeInfo_AddressOfMember调用后崩溃，且其他接口调用（比如IDispatch_GetTypeInfo）从未出错。

先贴出你的核心实现代码方便参考：

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 If
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 If
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")

崩溃的可能原因及修复方案 #

1. 未释放ITypeInfo接口引用（最可能的原因） #

COM接口遵循引用计数规则，调用IDispatch_GetTypeInfo获取ITypeInfo指针时，系统会自动增加该接口的引用计数。你的代码中没有调用ITypeInfo的Release方法来释放这个引用，导致内存泄漏。在32位环境下内存压力小，泄漏的内存可能被系统回收，但64位环境下，重复调用函数会积累大量未释放的接口资源，最终触发访问违规崩溃。

修复步骤：

• 添加ITypeInfo_Release函数来释放接口：

#If VBA7 Then
Private Function ITypeInfo_Release(ByVal iTypeInfoPtr As LongPtr) As Long
#Else
Private Function ITypeInfo_Release(ByVal iTypeInfoPtr As Long) As Long
#End If
    Dim hResult As Long
    ' 调用ITypeInfo的Release方法
    hResult = DispCallFunc(iTypeInfoPtr, ITypeInfoVtblOffset.oRelease, CC_STDCALL, vbLong, 0, ByVal 0, ByVal 0, ITypeInfo_Release)
    If hResult < 0 Then
        Err.Raise hResult, "ITypeInfo_Release"
    End If
End Function

• 在GetAddressOfClassMethod函数末尾添加释放逻辑：

' 获取方法地址后，释放ITypeInfo引用
If iTypeInfoPtr <> 0 Then
    ITypeInfo_Release iTypeInfoPtr
End If

2. 临时对象的生命周期问题 #

你测试时直接传递New Class1作为参数，这个临时对象在函数执行完毕后会被VBA自动销毁。如果ITypeInfo接口内部还持有对该对象的关联引用，后续可能访问已释放的内存空间，导致随机崩溃。

修复：
先将对象赋值给变量，再传入函数：

Dim clsInstance As New Class1
Debug.Print GetAddressOfClassMethod(clsInstance, "Name")

3. DispGetIDsOfNames的Locale参数问题 #

你使用Application.LanguageSettings.LanguageID(msoLanguageIDUI)作为LocaleID，但某些场景下这个Locale可能和类的类型库Locale不匹配，虽然不会直接导致崩溃，但可能引发未定义行为。建议直接传入0（默认系统Locale），简化代码同时避免潜在问题：

' 替换原有的localeID赋值和调用
IDispatch_GetTypeInfo iDispatchPtr, 0, 0, iTypeInfoPtr

4. 64位下指针传递的细微问题 #

在CreateInvokeArgs函数中，你用VarPtr(.args(i))获取参数地址，在64位环境下VarPtr返回Long类型，但argsPtrs是LongPtr数组。虽然VBA会自动转换，但确保参数类型一致更稳妥，可以修改为：

#If VBA7 Then
    .argsPtrs(i) = VarPtr(.args(i)) ' 64位下VarPtr返回LongPtr，没问题
#Else
    .argsPtrs(i) = VarPtr(.args(i))
#End If

不过这部分你的代码已经处理了，大概率不是崩溃主因，但保持类型一致性能减少潜在风险。

总结 #

最可能导致x64环境偶尔崩溃的原因是未释放ITypeInfo接口导致的内存泄漏，其次是临时对象生命周期过短引发的悬空指针访问。按照上述方案修复后，应该能解决崩溃问题。

内容的提问来源于stack exchange，提问作者Cristian Buse