x64 自定义类上的 For Each 枚举错误

Question

几个月前我在 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窗口中看到局部变量的值突然发生了变化：

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

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

一行行单步执行代码时，不会出现这个bug！

---

有关错误的更多信息

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

1. 添加Optional参数
2. 从函数中删除所有代码（请参阅下面显示此内容的代码）
3. 声明为IUnknown而不是IEnumVariant
4. 而不是Function声明为Property Get
5. 在方法签名中使用像Friend或这样的关键字Static
6. 加入DISPID_NEWENUM到设或设置的对口获取，甚至隐藏前者（即让咱们/私人设置）。

让我们尝试上面提到的第 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!", 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
    '
    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
   Or将集合设置为自身，将c参数传递ByVal给ShowBug方法（作为 Set，调用 IUnknown::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!", 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.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）是避免错误的方法。

---

这种行为的解释是什么？能否以更优雅的方式避免此错误？

编辑

传递CustomCollectionByVal 并不总是一种选择。考虑一个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行之前执行语句或方法调用。

Answer 1

怎么了

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

我们可以通过向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我在立即窗口中得到了这样的信息：

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

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

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

如果我们NewEnum在调用堆栈内部中断，则如下所示：

如何For Each调用NewEnum

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

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

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

挂钩调用

我们可以用Invoke我们自己的方法替换非 VB方法，以便进一步研究。在标准.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, Source 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, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source 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

我们运行Main2方法（标准 .bas 模块）来产生错误：

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!", vbInformation, "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

^{请注意，需要更多的虚拟 ptr 变量来防止崩溃，因为堆栈框架IDispatch_Invoke更大（因此，内存重叠更大）。}

通过运行上述，我得到：

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

再次，Set v = Nothing在For Each v In c结果之前添加一个：

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

如果我们打破我们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!", vbInformation, "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与使用我们自己的 hooked运行有Invoke什么不同？在这两种情况下DISP_E_MEMBERNOTFOUND都返回并且不NewEnum调用任何方法。

好吧，如果我们并排查看之前显示的调用堆栈：

我们可以看到非 VBInvoke没有作为单独的“非基本代码”条目推送到 VB 堆栈上。

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

错误原因

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

解决方法

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

1. 直接调用另一个方法（在该For Each行之前）例如Sin 1
2. 间接调用另一个方法（在该For Each行之前）：
   • 一个呼叫IUnknown::AddRef通过传递参数ByVal
   • IUnknown::QueryInterface使用stdole.IUnknown接口调用
   • 使用Set它会调用任何声明AddRef或Release或两者（例如Set c = c）。也可以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

尽管EnumHelper在任何实现自定义集合类的项目中，该类都是一个额外的类，但它也有一些优点：

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