在VBA中，如果你想要一个可迭代的Range像Python中的对象一样，你可以做类似的事情this https://codereview.stackexchange.com/q/60504/146810。然而，这种方法涉及一次性构建整个系列：

Set mCollection = New Collection
Dim i As Long
For i = startValue To endValue
    mCollection.Add i
Next

...如果您想要制作一个非常大的范围，这很糟糕，因为构建该集合需要很长时间和大量内存。这就是生成器的用途；当您循环时，它们会生成序列中的下一个项目。

Now 如果你希望一个类是可迭代的 https://stackoverflow.com/q/20194919/6609896，它必须返回一个[_NewEnum]，这是通过Set关键词。这告诉我一个For...Each循环只需要一个参考 to an Enum，自从Set关键字仅分配指向返回变量的指针，而不是实际值。

这给了一些杂耍的空间：

• For...Each（此后称为“迭代器”）需要一点内存来指示所提供的[_NewEnum];对枚举对象指针的引用
• 自定义类可以生成[_NewEnum]每当需要时，来自封装集合的指针
• 因此，也许，如果类知道迭代器在内存中的哪个位置寻找枚举指针，它就可以用指向不同枚举对象的指针覆盖该内存位。

换句话说：

• 在 a 的第一次迭代中For...Each循环，我的类返回一个variable其值是指向一个 Enum 的指针。该变量驻留在内存中指定的位置VarPtr(theVariable)
• 下一次迭代，我手动调用类的方法来生成第二个枚举
• 之后，该方法继续覆盖变量指针给出的地址处的第一个枚举对象的指针，并将其替换为ObjPtr()第二个枚举的。

如果这个理论是正确的，那么For Each循环现在将保存对不同值的引用[_NewEnum]，所以会做一些不同的事情。

我尝试这样做的方法如下：

发电机：NumberRange班级模块

注意：必须导入才能保留属性。

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

Private Type TRange
    encapsulated As Collection
    isGenerator As Boolean
    currentCount As Long
    maxCount As Long
    currentEnum As IUnknown
End Type

Private this As TRange

Public Sub fullRange(ByVal count As Long)
    'generate whole thing at once
    Dim i As Long
    this.isGenerator = False
    For i = 1 To count
        this.encapsulated.Add i
    Next i
End Sub

Public Sub generatorRange(ByVal count As Long)
    'generate whole thing at once
    this.isGenerator = True
    this.currentCount = 1
    this.maxCount = count
    this.encapsulated.Add this.currentCount      'initial value for first enumeration
End Sub

Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    'Attribute NewEnum.VB_UserMemId = -4
    Set this.currentEnum = this.encapsulated.[_NewEnum]
    Set NewEnum = this.currentEnum
End Property

Public Sub generateNext()
'This method is what should overwrite the current variable 
    If this.isGenerator And this.currentCount < this.maxCount Then
        this.currentCount = this.currentCount + 1
        replaceVal this.encapsulated, this.currentCount
        updateObject VarPtr(this.currentEnum), this.encapsulated.[_NewEnum]
    Else
        Err.Raise 5, Description:="Method reserved for generators"
    End If
End Sub

Private Sub Class_Initialize()
    Set this.encapsulated = New Collection
End Sub

Private Sub replaceVal(ByRef col As Collection, ByVal newval As Long)
    If col.count Then
        col.Remove 1
    End If
    col.Add newval
End Sub

包含一种一次性制作完整内容的标准方法或生成器方法，可与generateNext在循环。那里可能存在一个相差一的错误，但现在这并不重要。

内存管理辅助模块

这些方法只在我的32位系统上测试过。不过可能对两者都有效（使用条件编译）。

Option Explicit

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _
source As Any, ByVal bytes As Long)

Public Sub updateObject(ByVal variableAddress As LongPtr, ByVal replacementObject As Variant)
    #If VBA7 And Win64 Then
        Const pointerLength As Byte = 8
    #Else
        Const pointerLength As Byte = 4
    #End If
    CopyMemory ByVal variableAddress, ObjPtr(replacementObject), pointerLength
End Sub

最后一行是重要的一行；它说复制所提供对象的对象指针ObjPtr(replacementObject)到特定变量的位置ByVal variableAddress, the ByVal这里表明我们正在讨论变量本身的内存，而不是对变量的引用。变量已经包含对象指针这一事实并不重要

测试代码

Sub testGenerator()
    Dim g As New NumberRange
    g.generatorRange 10
    Dim val
    For Each val In g
        Debug.Print val
        g.generateNext
    Next val
End Sub

如果它正常工作，那么应该打印数字 1 到 10。但现在它在一次之后就脱离了循环。

那么为什么这不起作用呢？我想我已经遵循了我概述的所有步骤。我认为内存更新程序正在按预期工作，但我不确定，因为我无法查询ObjPtr()迭代器当前正在使用的枚举。也许For...Each只是不喜欢被打扰！欢迎任何有关如何实现所需行为的想法！

诗。经常保存，小心崩溃！

内存写入器的额外测试方法：

Public Sub testUpdater()
    'initialise
    Dim initialEnumeration As Object, newEnumeration As Object 'represent a [_NewEnum]
    Set initialEnumeration = CreateObject("System.Collections.ArrayList")
    Dim i As Long
    For i = 1 To 5
        initialEnumeration.Add i
    Next i

    'initialEnumeration pointers are what we want to change
    iterateObjPrinting "initialEnumeration at Start:", initialEnumeration

    'make some obvious change
    Set newEnumeration = initialEnumeration.Clone()
    newEnumeration(4) = 9
    iterateObjPrinting "newEnumeration before any copy:", newEnumeration

    'update the first one in place
    updateObject VarPtr(initialEnumeration), newEnumeration
    iterateObjPrinting "initialEnumeration after copy", initialEnumeration
End Sub

Private Sub iterateObjPrinting(ByVal message As String, ByVal obj As Variant)
    Dim val, result As String
    For Each val In obj
        result = result & " " & val
    Next val
    Debug.Print message, Trim(result)
End Sub

如何修复它

A 严重地第1337章 黑客命名DEXWERX http://www.vbforums.com/member.php?255623-DEXWERX写下了深层魔法 http://www.vbforums.com/showthread.php?854963-VB6-IEnumVARIANT-For-Each-support-without-a-typelib2017年，我适应了DEXWERX 的代码 https://github.com/dexwerx/VBWERX/blob/master/MEnumerator.bas针对这种情况，并在此处提供一个工作示例。这些作品是：

• MEnumerator：DEXWERX 代码的调整版本。这使得IEnumVARIANT从头开始在内存中组装它！
• IValueProvider：您的生成器应实现的直接 VBA 接口。这IEnumVARIANT由...制作MEnumerator将调用方法IValueProvider实例来获取要返回的元素。
• NumberRange：生成器类，它实现IValueProvider.

以下是粘贴到 VBA 中的测试代码，以及cls and bas要导入的文件。

测试代码

我把这个放进去ThisDocument.

Option Explicit

Sub testNumberRange()
    Dim c As New NumberRange
    c.generatorTo 10

    Dim idx As Long: idx = 1
    Dim val

    For Each val In c
        Debug.Print val
        If idx > 100 Then Exit Sub   ' Just in case of infinite loops
        idx = idx + 1
    Next val
End Sub

IValueProvider.cls

将其保存到文件并将其导入到 VBA 编辑器中。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IValueProvider"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' IValueProvider: Provide values.
Option Explicit
Option Base 0

' Return True if there are more values
Public Function HasMore() As Boolean
End Function

' Return the next value
Public Function GetNext() As Variant
End Function

NumberRange.cls

将其保存到文件并将其导入到 VBA 编辑器中。请注意，NewEnum函数现在仅仅委托给NewEnumerator函数于MEnumerator。这不使用集合，而是覆盖IValueProvider_HasMore and IValueProvider_GetNext使用方法MEnumerator.

另请注意，为了保持一致性，我将所有内容都从零开始。

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

' === The values we're actually going to return ===================
Implements IValueProvider

Private Type TRange
    isGenerator As Boolean
    currentCount As Long
    maxCount As Long
End Type

Private this As TRange

Private Function IValueProvider_GetNext() As Variant
    IValueProvider_GetNext = this.currentCount      'Or try Chr(65 + this.currentCount)
    this.currentCount = this.currentCount + 1
End Function

Private Function IValueProvider_HasMore() As Boolean
    IValueProvider_HasMore = this.isGenerator And (this.currentCount <= this.maxCount)
End Function

' === Public interface ============================================
Public Sub generatorTo(ByVal count As Long)
    this.isGenerator = True
    this.currentCount = 0
    this.maxCount = count - 1
End Sub

' === Enumeration support =========================================
Public Property Get NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
    'Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = NewEnumerator(Me)
End Property

' === Internals ===================================================
Private Sub Class_Initialize()
    ' If you needed to initialize `this`, you could do so here
End Sub

MEnumerator.bas

将其保存到文件并将其导入到 VBA 编辑器中。这IEnumVARIANT_Next称为IValueProvider方法并将它们转发给 VBA。这NewEnumerator方法构建了IEnumVARIANT.

Attribute VB_Name = "MEnumerator"
' Modified by cxw from code by http://www.vbforums.com/member.php?255623-DEXWERX
' posted at http://www.vbforums.com/showthread.php?854963-VB6-IEnumVARIANT-For-Each-support-without-a-typelib&p=5229095&viewfull=1#post5229095
' License: "Use it how you see fit." - http://www.vbforums.com/showthread.php?854963-VB6-IEnumVARIANT-For-Each-support-without-a-typelib&p=5232689&viewfull=1#post5232689
' Explanation at https://stackoverflow.com/a/52261687/2877364

'
' MEnumerator.bas
'
' Implementation of IEnumVARIANT to support For Each in VB6
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Type TENUMERATOR
    VTablePtr   As Long
    References  As Long
    Enumerable  As IValueProvider
    Index       As Long
End Type

Private Enum API
    NULL_ = 0
    S_OK = 0
    S_FALSE = 1
    E_NOTIMPL = &H80004001
    E_NOINTERFACE = &H80004002
    E_POINTER = &H80004003
#If False Then
    Dim NULL_, S_OK, S_FALSE, E_NOTIMPL, E_NOINTERFACE, E_POINTER
#End If
End Enum

Private Declare Function FncPtr Lib "msvbvm60" Alias "VarPtr" (ByVal Address As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function CopyBytesZero Lib "msvbvm60" Alias "__vbaCopyBytesZero" (ByVal Length As Long, Dst As Any, Src As Any) As Long
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cb As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal psz As Long, ByVal cblen As Long) As Long
Private Declare Function VariantCopyToPtr Lib "oleaut32" Alias "VariantCopy" (ByVal pvargDest As Long, ByRef pvargSrc As Variant) As Long
Private Declare Function InterlockedIncrement Lib "kernel32" (ByRef Addend As Long) As Long
Private Declare Function InterlockedDecrement Lib "kernel32" (ByRef Addend As Long) As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function NewEnumerator(ByRef Enumerable As IValueProvider) As IEnumVARIANT
' Class Factory
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Static VTable(6) As Long
    If VTable(0) = NULL_ Then
        ' Setup the COM object's virtual table
        VTable(0) = FncPtr(AddressOf IUnknown_QueryInterface)
        VTable(1) = FncPtr(AddressOf IUnknown_AddRef)
        VTable(2) = FncPtr(AddressOf IUnknown_Release)
        VTable(3) = FncPtr(AddressOf IEnumVARIANT_Next)
        VTable(4) = FncPtr(AddressOf IEnumVARIANT_Skip)
        VTable(5) = FncPtr(AddressOf IEnumVARIANT_Reset)
        VTable(6) = FncPtr(AddressOf IEnumVARIANT_Clone)
    End If

    Dim this As TENUMERATOR
    With this
        ' Setup the COM object
        .VTablePtr = VarPtr(VTable(0))
        .References = 1
        Set .Enumerable = Enumerable
    End With

    ' Allocate a spot for it on the heap
    Dim pThis As Long
    pThis = CoTaskMemAlloc(LenB(this))
    If pThis Then
        ' CopyBytesZero is used to zero out the original
        ' .Enumerable reference, so that VB doesn't mess up the
        ' reference count, and free our enumerator out from under us
        CopyBytesZero LenB(this), ByVal pThis, this
        DeRef(VarPtr(NewEnumerator)) = pThis
    End If
End Function

Private Function RefToIID$(ByVal riid As Long)
    ' copies an IID referenced into a binary string
    Const IID_CB As Long = 16&  ' GUID/IID size in bytes
    DeRef(VarPtr(RefToIID)) = SysAllocStringByteLen(riid, IID_CB)
End Function

Private Function StrToIID$(ByRef iid As String)
    ' converts a string to an IID
    StrToIID = RefToIID$(NULL_)
    IIDFromString StrPtr(iid), StrPtr(StrToIID)
End Function

Private Function IID_IUnknown() As String
    Static iid As String
    If StrPtr(iid) = NULL_ Then _
        iid = StrToIID$("{00000000-0000-0000-C000-000000000046}")
    IID_IUnknown = iid
End Function

Private Function IID_IEnumVARIANT() As String
    Static iid As String
    If StrPtr(iid) = NULL_ Then _
        iid = StrToIID$("{00020404-0000-0000-C000-000000000046}")
    IID_IEnumVARIANT = iid
End Function

Private Function IUnknown_QueryInterface(ByRef this As TENUMERATOR, _
                                         ByVal riid As Long, _
                                         ByVal ppvObject As Long _
                                         ) As Long
    If ppvObject = NULL_ Then
        IUnknown_QueryInterface = E_POINTER
        Exit Function
    End If

    Select Case RefToIID$(riid)
        Case IID_IUnknown, IID_IEnumVARIANT
            DeRef(ppvObject) = VarPtr(this)
            IUnknown_AddRef this
            IUnknown_QueryInterface = S_OK
        Case Else
            IUnknown_QueryInterface = E_NOINTERFACE
    End Select
End Function

Private Function IUnknown_AddRef(ByRef this As TENUMERATOR) As Long
    IUnknown_AddRef = InterlockedIncrement(this.References)
End Function

Private Function IUnknown_Release(ByRef this As TENUMERATOR) As Long
    IUnknown_Release = InterlockedDecrement(this.References)
    If IUnknown_Release = 0& Then
        Set this.Enumerable = Nothing
        CoTaskMemFree VarPtr(this)
    End If
End Function

Private Function IEnumVARIANT_Next(ByRef this As TENUMERATOR, _
                                   ByVal celt As Long, _
                                   ByVal rgVar As Long, _
                                   ByRef pceltFetched As Long _
                                   ) As Long

    Const VARIANT_CB As Long = 16 ' VARIANT size in bytes

    If rgVar = NULL_ Then
        IEnumVARIANT_Next = E_POINTER
        Exit Function
    End If

    Dim Fetched As Long
    Fetched = 0
    Dim element As Variant

    With this
        Do While this.Enumerable.HasMore
            element = .Enumerable.GetNext
            VariantCopyToPtr rgVar, element
            Fetched = Fetched + 1&
            If Fetched = celt Then Exit Do
            rgVar = PtrAdd(rgVar, VARIANT_CB)
        Loop
    End With

    If VarPtr(pceltFetched) Then pceltFetched = Fetched
    If Fetched < celt Then IEnumVARIANT_Next = S_FALSE
End Function

Private Function IEnumVARIANT_Skip(ByRef this As TENUMERATOR, ByVal celt As Long) As Long
    IEnumVARIANT_Skip = E_NOTIMPL
End Function

Private Function IEnumVARIANT_Reset(ByRef this As TENUMERATOR) As Long
    IEnumVARIANT_Reset = E_NOTIMPL
End Function

Private Function IEnumVARIANT_Clone(ByRef this As TENUMERATOR, ByVal ppEnum As Long) As Long
    IEnumVARIANT_Clone = E_NOTIMPL
End Function

Private Function PtrAdd(ByVal Pointer As Long, ByVal Offset As Long) As Long
    Const SIGN_BIT As Long = &H80000000
    PtrAdd = (Pointer Xor SIGN_BIT) + Offset Xor SIGN_BIT
End Function

Private Property Let DeRef(ByVal Address As Long, ByVal Value As Long)
    GetMem4 Value, ByVal Address
End Property

原始答案：为什么现有代码不起作用

I can't tell you how to fix it, but I can tell you why. This is too long for a comment :) .

您正在导出一个Collection供您自己使用的枚举器。直的——Collection的版本testGenerator具有相同的行为：

Option Explicit
Sub testCollection()
    Dim c As New Collection
    Dim idx As Long: idx = 1
    Dim val
    c.Add idx
    For Each val In c
        Debug.Print val
        c.Add idx

        If idx > 100 Then Exit Sub    ' deadman, to break an infinite loop if it starts working!
        idx = idx + 1
    Next val
End Sub

这段代码打印1然后退出For Each loop.

我相信updateObject呼叫没有按照您的预期进行。以下内容是根据我自己的知识，也。当。。。的时候For Each循环开始，VBA 得到一个IUnknown from _NewEnum。然后VBA调用QueryInterface on the IUnknown得到自己的IEnumVARIANT指向单个引用计数枚举器对象的指针。结果，For Each有自己的枚举器副本。

然后，当你打电话时updateObject，它改变了内容this.currentEnum。然而，这并不是For Each循环实际上正在寻找。因此，replaceVal()在迭代集合时修改集合。这VB.NET 文档 https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/for-each-next-statement对这个话题有话要说。我怀疑 VB.NET 的行为是从 VBA 继承的，因为它与您所看到的相符。具体来说：

返回的枚举器对象GetEnumerator [of System.Collections.IEnumerable] 通常不允许您通过添加、删除、替换或重新排序任何元素来更改集合。如果您在发起收集后更改集合For Each...Next循环，枚举器对象变得无效......

因此，您可能必须自己推出IEnumerator实现而不是重用Collection.

Edit我发现这个链接 http://www.vtsoftware.co.uk/tools/enumeration.htm建议你需要实施IEnumVARIANT，VBA 本身不会执行此操作（edit但可以做，如上图所示！）。我自己还没有尝试过该链接中的信息，但请传递它以防它有帮助。