Bug with For Each enumeration on x64 Custom Classes

问题

I have found a bug in VBA a few months ago and was unable to find a decent workaround. The bug is really annoying as it kind of restricts a nice language feature.

When using a Custom Collection Class it is quite common to want to have an enumerator so that the class can be used in a For Each loop. This can be done by adding this line:

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

immediately after the function/property signature line either by:

Exporting the class module, editing the contents in a text editor, and then importing back
Using Rubberduck annotation '@Enumerator above the function signature and then syncronizing

Unfortunately, on x64, using the above-mentioned feature, causes the wrong memory to get written and leads to the crash of the Application in certain cases (discussed later).

Reproducing the bug

CustomCollection class:

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

Code in a standard module:

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

By running the Main method, the code will stop on the Assert line in the ShowBug method and you can see in the Locals window that local variables got their values changed out of nowhere:

where ptr1 is equal to ObjPtr(c). The more variables are used inside the NewEnum method (including Optional parameters) the more ptrs in the ShowBug method get written with a value (memory address).

Needless to say, removing the local ptr variables inside the ShowBug method would most certainly cause the crash of the Application.

When stepping through code line by line, this bug will not occur!

More on the bug

The bug is not related with the actual Collection stored inside the CustomCollection. The memory gets written immediately after the NewEnum function is invoked. So, basically doing any of the following is not helping (tested):

adding Optional parameters
removing all code from within the function (see below code showing this)
declaring as IUnknown instead of IEnumVariant
instead of Function declaring as Property Get
using keywords like Friend or Static in the method signature
adding the DISPID_NEWENUM to a Let or Set counterpart of the Get, or even hiding the former (i.e. make the Let/Set private).

Let us try step 2 mentioned above. If CustomCollection becomes:

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

and the code used for testing is changed to:

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

running Main produces the same bug.

Workaround

Reliable ways, that I found, to avoid the bug:

Call a method (basically leave the ShowBug method) and come back. This needs to happen before the For Each line is executed (before meaning it can be anywhere in the same method, not necessarily the exact line before):
```
Sin 0 'Or VBA.Int 1 - you get the idea
For Each v In c
Next v
```
Cons: Easy to forget
Do a Set statement. It could be on the variant used in the loop (if no other objects are used). As in point 1 above, this needs to happen before the For Each line is executed:
```
Set v = Nothing
For Each v In c
Next v
```
or even by setting the collection to itself with Set c = c
Or, passing the c parameter ByVal to the ShowBug method (which, as Set, does a call to IUnknown::AddRef)
Cons: Easy to forget

Using a separate EnumHelper class that is the only class ever used for enumerating:

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 would become:

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

and the calling code:

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

Obviously, the reserved DISPID was removed from the CustomCollection class.

Pros: forcing the For Each on the .NewEnum function instead of the custom collection directly. This avoids any crash caused by the bug.

Cons: always needing the extra EnumHelper class. Easy to forget to add the .NewEnum in the For Each line (would only trigger a runtime error).

The last approach (3) works because when c.NewEnum is executed the ShowBug method is exited and then returned before the invocation of the Property Get EnumVariant inside the EnumHelper class. Basically approach (1) is the one avoiding the bug.

What is the explanation for this behavior? Can this bug be avoided in a more elegant way?

EDIT

Passing the CustomCollection ByVal is not always an option. Consider a 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

And now a calling routine:

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

Obviously, the example is a bit forced but it is quite common to have a "parent" object containing a Custom Collection of "child" objects and the "parent" might want to do some operation involving some or all of the "children".

In this case it would be easy to forget to do a Set statement or a method call before the For Each line.

回答1:

What is happening

It appears that the stack frames are overlapping although they should not. Having enough variables in the ShowBug method prevents a crash and the values of the variables (in the caller subroutine) are simply changed because the memory they refer to is also used by another stack frame (the called subroutine) that was added/pushed later at the top of the call stack.

We can test this by adding a couple of Debug.Print statements to the same code from the question.

The CustomCollection class:

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

And the calling code, in a standard .bas module:

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

By running Main I get something like this in the Immediate Window:

The address of the NewEnum return value is clearly at a memory address in between the ptr0 and ptr9 variables of the ShowBug method. So, that is why the variables get values out of nowhere, because they actually come from the stack frame of the NewEnum method (like the address of the object's vtable or the address of the IEnumVariant interface). If the variables would not be there, then the crash is obvious as more critical parts of memory are being overwritten (e.g. the frame pointer address for the ShowBug method). As the stack frame for the NewEnum method is larger (we can add local variables for example, to increase the size), the more memory is shared between the top stack frame and the one below in the call stack.

What happens if we workaround the bug with the options described in the question? Simply adding a Set v = Nothing before the For Each v In c line, results into:

Showing both previous value and the current one (bordered blue), we can see that the NewEnum return is at a memory address outside of the ptr0 and ptr9 variables of the ShowBug method. It seems that the stack frame was correctly allocated using the workaround.

If we break inside the NewEnum the call stack looks like this:

How For Each invokes NewEnum

Every VBA class is derived from IDispatch (which in turn is derived from IUnknown).

When a For Each... loop is called on an object, that object's IDispatch::Invoke method is called with a dispIDMember equal to -4. A VBA.Collection already has such a member but for VBA custom classes we mark our own method with Attribute NewEnum.VB_UserMemId = -4 so that Invoke can call our method.

Invoke is not called directly if the interface used in the For Each line is not derived from IDispatch. Instead, IUnknown::QueryInterface is called first and asked for the IDispatch interface. In this case Invoke is obviously called only after IDispatch interface is returned. Right here is the reason why using For Each on an Object declared As IUnknown will not cause the bug regardless if it is passed ByRef or if it is a global or class member custom collection. It simply uses workaround number 1 mentioned in the question (i.e. calls another method) although we cannot see it.

Hooking Invoke

We can replace the non-VB Invoke method with one of our own in order to investigate further. In a standard .bas module we need the following code to hook:

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

and we run the Main2 method (standard .bas module) to produce the bug:

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

^{Notice that more dummy ptr variables are needed to prevent the crash as the stack frame for IDispatch_Invoke is bigger (hence, the memory overlap is bigger).}

By running the above, I get:

The same bug occurs although the code never reaches the NewEnum method due to the hooking of the Invoke method. The stack frame is again wrongfully allocated.

Again, adding a Set v = Nothing before the For Each v In c results into:

The stack frame is allocated correctly (bordered green). This indicates that the issue is not with the NewEnum method and also not with our replacement Invoke method. Something is happening before our Invoke is called.

If we break inside our IDispatch_Invoke the call stack looks like this:

One last example. Consider a blank (with no code) class Class1. If we run Main3 in the following code:

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

The bug simply does not occur. How is this different from running Main2 with our own hooked Invoke? In both cases DISP_E_MEMBERNOTFOUND is returned and no NewEnum method is called.

Well, if we look at the previously shown call stacks side by side:

we can see that the non-VB Invoke is not pushed on the VB stack as a separate "Non-Basic Code" entry.

Apparently, the bug only occurs if a VBA method is called (either NewEnum via the original non-VB Invoke or our own IDispatch_Invoke). If a non-VB method is called (like the original IDispatch::Invoke with no following NewEnum) the bug does not occur as in Main3 above. No bug occurs when running For Each... on a VBA Collection within the same circumstances either.

The bug cause

As all the above examples suggest, the bug can be summarized with the following:
For Each calls IDispatch::Invoke which in turn calls NewEnum while the stack pointer has not been incremented with the size of the ShowBug stack frame. Hence, same memory is used by both frames (the caller ShowBug and the callee NewEnum).

Workarounds

Ways to force the correct incrementation of the stack pointer:

call another method directly (before the For Each line) e.g. Sin 1
call another method indirectly (before the For Each line):
- a call to IUnknown::AddRef by passing the argument ByVal
- a call to IUnknown::QueryInterface by using the stdole.IUnknown interface
- using a Set statement which will call either AddRef or Release or both (e.g. Set c = c). Could also call QueryInterface depending on the source and target interfaces

As suggested in the EDIT section of the question, we don't always have the possibility to pass the Custom Collection class ByVal because it could simply be a global variable, or a class member and we would need to remember to do a dummy Set statement or to call another method before For Each... is executed.

Solution

I still could not find a better solution that the one presented in the question, so I am just going to replicate the code here as part of the answer, with a slight tweak.

EnumHelper class:

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 would now become something like:

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

You would just need to call with For Each v in c.NewEnum

Although, the EnumHelper class would be an extra class needed in any project implementing a custom collection class, there are a couple of advantages as well:

You would never need to add the Attribute [MethodName].VB_UserMemId = -4 to any other custom collection class. This is even more useful for users that do not have RubberDuck installed ('@Enumerator annotation), as they would need to export, edit the .cls text file and import back for each custom collection class
You could expose multiple EnumHelpers for the same class. Consider a custom dictionary class. You could have an ItemsEnum and a KeysEnum at the same time. Both For Each v in c.ItemsEnum and For Each v in c.KeysEnum would work
You would never forget to use one of the workarounds presented above as the method exposing the EnumHelper class would be called before Invoke is calling member ID -4
You would not get crashes anymore. If you forget to call with For Each v in c.NewEnum and instead use For Each v in c you would just get a runtime error which would be picked up in testing anyway. Of course you could still force a crash by passing the result of c.NewEnum to another method ByRef which would then need to execute a For Each before any other method call or Set statement. Highly unlikely you would ever do that
Obvious but worth mentioning, you would use the same EnumHelper class for all the custom collection classes you might have in a project

来源：https://stackoverflow.com/questions/63848617/bug-with-for-each-enumeration-on-x64-custom-classes

标签

excel

vba

64-bit

enumeration

custom-collection