x64自定义类上的每个枚举的错误

编程问答 2022-08-11

问题描述

几个月前，我在VBA中发现了一个错误，并且找不到合适的解决方法。该错误确实令人讨厌，因为它限制了良好的语言功能。

在使用自定义集合类时，通常需要有一个枚举数，以便可以在For Each循环中使用该类。这可以通过添加以下行来完成：

Attribute [MethodName].VB_UserMemId = -4 'The reserved disPID_NEWENUM

在功能/特性签名行之后立即通过以下方式之一：

  1. 导出类模块，在文本编辑器中编辑内容，然后重新导入
  2. 在函数签名上方使用Rubberduck注释'@Enumerator，然后进行同步

不幸的是，在x64上，使用上述功能会导致写入错误的内存，并在某些情况下导致应用程序崩溃（稍后讨论）。

再现错误

CustomCollection类：

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CustomCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = m_coll.[_NewEnum]
End Function

标准模块中的代码：

Option Explicit

Sub Main()
    #If Win64 Then
        Dim c As New CustomCollection
        c.Add 1
        c.Add 2
        ShowBug c
    #Else
        MsgBox "This bug does not occur on 32 bits!",vbinformation,"Cancelled"
    #End If
End Sub

Sub ShowBug(c As CustomCollection)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    For Each v In c
    Next v
    Debug.Assert ptr0 = 0
End Sub

通过运行Main方法，代码将在Assert方法的ShowBug行处停止，您可以在 Locals 窗口中看到本地变量的值无处不在：

enter image description here


其中ptr1等于ObjPtr(c)。在NewEnum方法中使用的变量（包括可选参数）越多，在ShowBug方法中的ptrs写入的值（内存地址）就越多。

不用说，删除ShowBug方法内的本地 ptr 变量肯定会导致应用程序崩溃。

逐行浏览代码时，不会发生此错误！

有关该错误的更多信息

该错误与存储在Collection中的实际CustomCollection无关。调用NewEnum函数后，将立即写入内存。因此，基本上执行以下任何一项操作都无济于事（经过测试）：

  1. 添加Optional个参数
  2. 从函数中删除所有代码（请参见下面显示此代码的代码）
  3. 声明为IUnkNown而不是IEnumVariant
  4. 代替Function声明为Property Get
  5. 在方法签名中使用Friend或Static之类的关键字
  6. 将disPID_NEWENUM添加到 Get 的 Let 或 Set 中，甚至隐藏前者（即，将Let / Set设为私有）。

让我们尝试上述第2步。如果CustomCollection变为：

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CustomCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
End Function

，用于测试的代码更改为：

Sub Main()
    #If Win64 Then
        Dim c As New CustomCollection
        ShowBug c
    #Else
        MsgBox "This bug does not occur on 32 bits!","Cancelled"
    #End If
End Sub

Sub ShowBug(c As CustomCollection)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    On Error Resume Next
    For Each v In c
    Next v
    On Error GoTo 0
    Debug.Assert ptr0 = 0
End Sub

运行Main会产生相同的错误。

解决方法

我找到了避免错误的可靠方法：

  1. 调用一个方法（基本上离开ShowBug方法）并返回。这需要在执行For Each行之前发生（之前，这意味着它可以在同一方法中的任何地方，不一定是之前的确切行）：

    Sin 0 'Or VBA.Int 1 - you get the idea
For Each v In c
Next v

    缺点：容易忘记

  2. 执行Set语句。它可能在循环中使用的变体上（如果未使用其他对象）。如以上第1点所述，这需要在执行For Each行之前发生：

    Set v = nothing
For Each v In c
Next v

    ，甚至可以使用Set c = c将集合设置为自身
    或者，将 c 参数ByVal传递给ShowBug方法（作为Set，将调用IUnknonw :: AddRef）
    缺点：容易忘记

  3. 使用单独的EnumHelper类，这是有史以来唯一用于枚举的类：

    VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "EnumHelper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_enum As IEnumVARIANT

Public Property Set EnumVariant(newEnum_ As IEnumVARIANT)
    Set m_enum = newEnum_
End Property
Public Property Get EnumVariant() As IEnumVARIANT
Attribute EnumVariant.VB_UserMemId = -4
    Set EnumVariant = m_enum
End Property

    CustomCollection将变为：

    VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CustomCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As EnumHelper
    Dim eHelper As New EnumHelper
    '
    Set eHelper.EnumVariant = m_coll.[_NewEnum]
    Set NewEnum = eHelper
End Function

    和调用代码：

    Option Explicit

Sub Main()
    #If Win64 Then
        Dim c As New CustomCollection
        c.Add 1
        c.Add 2
        ShowBug c
    #Else
        MsgBox "This bug does not occur on 32 bits!","Cancelled"
    #End If
End Sub

Sub ShowBug(c As CustomCollection)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    For Each v In c.NewEnum
        Debug.Print v
    Next v
    Debug.Assert ptr0 = 0
End Sub

    很明显，保留的disPID已从CustomCollection类中删除。

    优点：强制For Each函数上的.NewEnum而不是直接自定义集合。这样可以避免由错误引起的崩溃。

    缺点：总是需要额外的EnumHelper类。很容易忘记在.NewEnum行中添加For Each（只会触发运行时错误）。

最后一种方法（3）之所以起作用，是因为在执行c.NewEnum类内的ShowBug之前，Property Get EnumVariant方法被执行后，将退出EnumHelper方法。基本上，方法（1）是避免bug的一种方法。

对此行为的解释是什么？可以更优雅地避免此错误吗？

编辑

通过CustomCollection ByVal并非总是一种选择。考虑一个Class1：

Option Explicit

Private m_collection As CustomCollection

Private Sub Class_Initialize()
    Set m_collection = New CustomCollection
End Sub
Private Sub Class_Terminate()
    Set m_collection = nothing
End Sub

Public Sub AddElem(d As Double)
    m_collection.Add d
End Sub

Public Function SumElements() As Double
    Dim v As Variant
    Dim s As Double
    
    For Each v In m_collection
        s = s + v
    Next v
    SumElements = s
End Function

现在是一个调用例程：

Sub ForceBug()
    Dim c As Class1
    Set c = New Class1
    c.AddElem 2
    c.AddElem 5
    c.AddElem 7
    
    Debug.Print c.SumElements 'BOOM - Application crashes
End Sub

很明显，该示例有点强迫，但是使用包含“子”对象的自定义集合的“父”对象是很常见的，并且“父”对象可能要执行涉及一些“或全部”“儿童”。

在这种情况下，很容易忘记在Set行之前执行For Each语句或方法调用。

解决方法

发生了什么

看起来 stack frames 是重叠的，尽管它们不应该重叠。在 ShowBug 方法中有足够多的变量可以防止崩溃，并且变量的值（在调用者子例程中）被简单地更改，因为它们引用的内存也被添加的另一个堆栈帧（被调用的子例程）使用/push 到调用堆栈的顶部。

我们可以通过向问题中的相同代码添加几个 Debug.Print 语句来测试这一点。

CustomCollection 类：

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CustomCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = Nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
    Debug.Print "The NewEnum return address " & VarPtr(NewEnum) & " should be outside of the"
    Set NewEnum = m_coll.[_NewEnum]
End Function

以及标准 .bas 模块中的调用代码：

Option Explicit

Sub Main()
    #If Win64 Then
        Dim c As New CustomCollection
        c.Add 1
        c.Add 2
        ShowBug c
    #Else
        MsgBox "This bug does not occur on 32 bits!",vbInformation,"Cancelled"
    #End If
End Sub

Sub ShowBug(ByRef c As CustomCollection)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    For Each v In c
    Next v
    Debug.Print VarPtr(ptr9) & " - " & VarPtr(ptr0) & " memory range"
    Debug.Assert ptr0 = 0
End Sub

通过运行 Main，我在即时窗口中得到了这样的信息：
enter image description here

NewEnum 返回值的地址显然位于 ptr0 方法的 ptr9 和 ShowBug 变量之间的内存地址。所以，这就是变量从哪里获取值的原因，因为它们实际上来自 NewEnum 方法的堆栈帧（例如对象的 vtable 的地址或 IEnumVariant 接口的地址）。如果变量不存在，那么崩溃很明显，因为内存的更关键部分被覆盖（例如 ShowBug 方法的帧指针地址）。由于 NewEnum 方法的堆栈框架较大（例如，我们可以添加局部变量以增加大小），因此调用堆栈中顶部堆栈框架和下方堆栈框架之间共享的内存越多。>

如果我们使用问题中描述的选项解决该错误，会发生什么？只需在 Set v = Nothing 行前添加一个 For Each v In c，结果为：
enter image description here

同时显示前一个值和当前值（蓝色边框），我们可以看到 NewEnum 返回位于 ptr0 和 ptr9 变量之外的内存地址{1}} 方法。似乎使用变通方法正确分配了堆栈帧。

如果我们在 ShowBug 内部中断，调用堆栈如下所示：
enter image description here

NewEnum 如何调用 For Each

每个 VBA 类都派生自 IDispatch（而后者又派生自 IUnknown）。

当对一个对象调用 NewEnum 循环时，该对象的 For Each... 方法被调用，其中 IDispatch::Invoke 等于 -4。 VBA.Collection 已经有这样的成员，但对于 VBA 自定义类，我们用 dispIDMember 标记我们自己的方法，以便 Invoke 可以调用我们的方法。

如果 Attribute NewEnum.VB_UserMemId = -4 行中使用的接口不是从 Invoke 派生的，则不会直接调用

For Each。相反，首先调用 IDispatch 并请求 IDispatch 接口。在这种情况下 IUnknown::QueryInterface 显然被称为 只有在 IDispatch 接口返回后。这就是为什么在声明为 Invoke 的对象上使用 For Each 不会导致错误的原因，无论它是传递 As IUnknown 还是全局或类成员自定义集合。尽管我们看不到它，但它只是使用了问题中提到的解决方法 1（即调用另一个方法）。

挂钩调用

我们可以用我们自己的方法替换非 VB ByRef 方法，以便进一步调查。在标准的 Invoke 模块中，我们需要以下代码来挂钩：

.bas

然后我们运行 Option Explicit #If Mac Then #If VBA7 Then Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any,Source As Any,ByVal Length As LongPtr) As LongPtr #Else Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any,ByVal Length As Long) As Long #End If #Else 'Windows 'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx #If VBA7 Then Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any,ByVal Length As LongPtr) #Else Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any,ByVal Length As Long) #End If #End If #If Win64 Then Private Const PTR_SIZE As Long = 8 #Else Private Const PTR_SIZE As Long = 4 #End If #If VBA7 Then Private newInvokePtr As LongPtr Private oldInvokePtr As LongPtr Private invokeVtblPtr As LongPtr #Else Private newInvokePtr As Long Private oldInvokePtr As Long Private invokeVtblPtr As Long #End If 'https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-idispatch-invoke Function IDispatch_Invoke(ByVal this As Object _,ByVal dispIDMember As Long _,ByVal riid As LongPtr _,ByVal lcid As Long _,ByVal wFlags As Integer _,ByVal pDispParams As LongPtr _,ByVal pVarResult As LongPtr _,ByVal pExcepInfo As LongPtr _,ByRef puArgErr As Long _ ) As Long Const DISP_E_MEMBERNOTFOUND = &H80020003 ' Debug.Print "The IDispatch::Invoke return address " & VarPtr(IDispatch_Invoke) & " should be outside of the" IDispatch_Invoke = DISP_E_MEMBERNOTFOUND End Function Sub HookInvoke(obj As Object) If obj Is Nothing Then Exit Sub #If VBA7 Then Dim vTablePtr As LongPtr #Else Dim vTablePtr As Long #End If ' newInvokePtr = VBA.Int(AddressOf IDispatch_Invoke) CopyMemory vTablePtr,ByVal ObjPtr(obj),PTR_SIZE ' invokeVtblPtr = vTablePtr + 6 * PTR_SIZE CopyMemory oldInvokePtr,ByVal invokeVtblPtr,PTR_SIZE CopyMemory ByVal invokeVtblPtr,newInvokePtr,PTR_SIZE End Sub Sub RestoreInvoke() If invokeVtblPtr = 0 Then Exit Sub ' CopyMemory ByVal invokeVtblPtr,oldInvokePtr,PTR_SIZE invokeVtblPtr = 0 oldInvokePtr = 0 newInvokePtr = 0 End Sub 方法（标准 .bas 模块）来产生错误：

Main2

请注意，需要更多的虚拟 ptr 变量来防止崩溃，因为 Option Explicit Sub Main2() #If Win64 Then Dim c As Object Set c = New CustomCollection c.Add 1 c.Add 2 ' HookInvoke c ShowBug2 c RestoreInvoke #Else MsgBox "This bug does not occur on 32 bits!","Cancelled" #End If End Sub Sub ShowBug2(ByRef c As CustomCollection) Dim ptr00 As LongPtr Dim ptr01 As LongPtr Dim ptr02 As LongPtr Dim ptr03 As LongPtr Dim ptr04 As LongPtr Dim ptr05 As LongPtr Dim ptr06 As LongPtr Dim ptr07 As LongPtr Dim ptr08 As LongPtr Dim ptr09 As LongPtr Dim ptr10 As LongPtr Dim ptr11 As LongPtr Dim ptr12 As LongPtr Dim ptr13 As LongPtr Dim ptr14 As LongPtr Dim ptr15 As LongPtr Dim ptr16 As LongPtr Dim ptr17 As LongPtr Dim ptr18 As LongPtr Dim ptr19 As LongPtr ' Dim v As Variant ' On Error Resume Next For Each v In c Next v Debug.Print VarPtr(ptr19) & " - " & VarPtr(ptr00) & " range on the call stack" Debug.Assert ptr00 = 0 End Sub 的堆栈框架更大（因此，内存重叠更大）。

通过运行上述，我得到：
enter image description here

尽管由于 IDispatch_Invoke 方法的挂钩，代码从未到达 NewEnum 方法，但仍会出现相同的错误。堆栈帧再次被错误分配。

同样，在 Invoke 之前添加一个 Set v = Nothing 结果为： enter image description here

堆栈帧分配正确（绿色边框）。这表明问题不在于 For Each v In c 方法，也不在于我们的替换 NewEnum 方法。在调用我们的 Invoke 之前发生了一些事情。

如果我们在 Invoke 内部中断，调用堆栈如下所示：
enter image description here

最后一个例子。考虑一个空白（没有代码）类 IDispatch_Invoke。如果我们在以下代码中运行 Class1：

Main3

该错误根本不会发生。这与使用我们自己的钩子 Option Explicit Sub Main3() #If Win64 Then Dim c As New Class1 ShowBug3 c #Else MsgBox "This bug does not occur on 32 bits!","Cancelled" #End If End Sub Sub ShowBug3(ByRef c As Class1) Dim ptr0 As LongPtr Dim ptr1 As LongPtr Dim ptr2 As LongPtr Dim ptr3 As LongPtr Dim ptr4 As LongPtr Dim ptr5 As LongPtr Dim ptr6 As LongPtr Dim ptr7 As LongPtr Dim ptr8 As LongPtr Dim ptr9 As LongPtr ' Dim v As Variant ' On Error Resume Next For Each v In c Next v Debug.Assert ptr0 = 0 End Sub 运行 Main2 有何不同？在这两种情况下，都返回 Invoke 并且没有调用 DISP_E_MEMBERNOTFOUND 方法。

好吧，如果我们并排查看前面显示的调用堆栈：
enter image description here
我们可以看到非 VB NewEnum 没有作为单独的“非基本代码”条目推送到 VB 堆栈上。

显然，该错误仅在调用 VBA 方法（通过原始非 VB Invoke 调用 NewEnum 或我们自己的 IDispatch_Invoke）时才会发生。如果调用非 VB 方法（如原始 IDispatch::Invoke 没有跟在 NewEnum 之后），则不会像上面的 Invoke 那样发生错误。在相同情况下在 VBA 集合上运行 Main3 时也不会出现错误。

错误原因

正如上面所有的例子所表明的，这个错误可以总结如下：
For Each... 调用 For Each，后者又调用 IDispatch::Invoke，而堆栈指针还没有随着 NewEnum 堆栈帧的大小增加。因此，两个帧（调用方 ShowBug 和被调用方 ShowBug）使用相同的内存。

解决方法

强制正确递增堆栈指针的方法：

  1. 直接调用另一个方法（在 NewEnum 行之前）例如For Each
  2. 间接调用另一个方法（在 Sin 1 行之前）：
    • 通过传递参数 For Each 调用 IUnknown::AddRef
    • 使用 ByVal 接口调用 IUnknown::QueryInterface
    • 使用 stdole.IUnknown 语句，该语句将调用 Set 或 AddRef 或两者（例如 Release）。也可以根据源和目标接口调用 Set c = c

正如问题的 EDIT 部分所建议的，我们并不总是有可能传递自定义集合类 QueryInterface，因为它可能只是一个全局变量，或者类成员，我们需要记住在执行 ByVal 之前执行伪 Set 语句或调用另一个方法。

解决方案

我仍然找不到比问题中提出的更好的解决方案，所以我只是将代码复制到这里作为答案的一部分，并稍作调整。

For Each... 类：

EnumHelper

VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "EnumHelper" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private m_enum As IEnumVARIANT Public Property Set EnumVariant(newEnum_ As IEnumVARIANT) Set m_enum = newEnum_ End Property Public Property Get EnumVariant() As IEnumVARIANT Attribute EnumVariant.VB_UserMemId = -4 Set EnumVariant = m_enum End Property Public Property Get Self() As EnumHelper Set Self = Me End Property 现在会变成这样：

CustomCollection

您只需要使用 Option Explicit Private m_coll As Collection Private Sub Class_Initialize() Set m_coll = New Collection End Sub Private Sub Class_Terminate() Set m_coll = Nothing End Sub Public Sub Add(v As Variant) m_coll.Add v End Sub Public Function NewEnum() As EnumHelper With New EnumHelper Set .EnumVariant = m_coll.[_NewEnum] Set NewEnum = .Self End With End Function

调用

尽管 For Each v in c.NewEnum 类是任何实现自定义集合类的项目都需要的额外类，但它也有几个优点：

  1. 您永远不需要将 EnumHelper 添加到任何其他自定义集合类。这对于没有安装 RubberDuck（Attribute [MethodName].VB_UserMemId = -4 注释）的用户更有用，因为他们需要导出、编辑 .cls 文本文件并为每个自定义集合类导入
  2. 您可以为同一个类公开多个 EnumHelper。考虑一个自定义字典类。您可以同时拥有 '@Enumerator 和 ItemsEnum。 KeysEnum 和 For Each v in c.ItemsEnum 都可以使用
  3. 您永远不会忘记使用上述解决方法之一，因为将在 For Each v in c.KeysEnum 调用成员 ID -4 之前调用公开 EnumHelper 类的方法
  4. 您不会再遇到崩溃了。如果您忘记使用 Invoke 调用而是使用 For Each v in c.NewEnum，您只会得到一个运行时错误，无论如何都会在测试中发现该错误。当然，您仍然可以通过将 For Each v in c 的结果传递给另一个方法 c.NewEnum 来强制崩溃，然后该方法需要在任何其他方法调用或 ByRef 语句之前执行 For Each .你极不可能这样做
  5. 显而易见但值得一提的是，您可以为项目中可能拥有的所有自定义集合类使用相同的 Set 类
64-bitcustom-collectionenumerationexcelexcelvba