在VBA中，如果您想要像Python中那样的可迭代Range对象，则可以执行类似this的操作。但是，该方法涉及一次性建立整个范围：
Set mCollection = New Collection Dim i As Long For i = startValue To endValue mCollection.Add i Next
...如果您想创建一个很大的范围，这是不好的，因为建立该集合需要花费很多时间和大量内存。这就是发电机的作用；它们会在您循环时生成序列中的下一项。
现在if you want a class to be iterable，它必须返回[_NewEnum]，这是通过Set关键字完成的。这告诉我，For...Each循环仅需要对Enum的 reference ，因为Set关键字仅将指针分配给返回的变量，而不是实际的指针。值。
这为杂耍提供了空间：
For...Each（以下称为“迭代器”）需要一定的内存，用于指示所提供的[_NewEnum]的方向；对枚举对象的指针的引用[_NewEnum]指针换句话说：
For...Each循环的第一次迭代中，我的类返回一个变量，其值是指向一个枚举的指针。该变量位于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的位置，此处的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的数字。但是现在，它走了一圈之后就退出了循环。
那为什么不起作用？我想我已经遵循了我概述的所有步骤。我认为内存更新程序可以按预期工作，但是我不确定，因为我无法查询Iterator当前正在使用的枚举的ObjPtr()。也许For...Each只是不喜欢被打扰！关于如何实现所需行为的任何想法都欢迎您！
Ps。经常保存，当心崩溃！
内存编写器的奖励测试方法：
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
答案 0 :(得分：6)
一位名叫DEXWERX的认真的1337年黑客在2017年写下了deep magic。我将DEXWERX's code应用于这种情况，并在此处提供了一个有效的示例。这些是：
MEnumerator：DEXWERX代码的经过调整的版本。通过从头开始将IEnumVARIANT组装到内存中，可以制成IValueProvider！IEnumVARIANT：生成器应实现的纯VBA接口。由MEnumerator创建的IValueProvider将调用NumberRange实例上的方法以获取要返回的元素。IValueProvider：生成器类，它实现cls。以下是要粘贴到VBA中的测试代码，以及要导入的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.clsVERSION 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
将其保存到文件中，然后导入到VBA编辑器中。
NumberRange.clsNewEnum 将其保存到文件中，然后导入到VBA编辑器中。请注意，NewEnumerator函数现在仅委托给MEnumerator中的IValueProvider_HasMore函数。代替使用集合，这会覆盖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.basIEnumVARIANT_Next 将其保存到文件中，然后导入到VBA编辑器中。 IValueProvider调用NewEnumerator方法并将其转发到VBA。 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
。
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，然后退出updateObject循环。
我相信For Each通话没有达到您的期望。以下内容基于我自己的知识以及this forum post。当IUnknown循环开始时，VBA从_NewEnum获取一个QueryInterface。然后，VBA在IUnknown上调用IEnumVARIANT，以将其自己的For Each指针放入单个引用计数的枚举器对象。结果，updateObject拥有自己的枚举数副本。
然后，当您调用this.currentEnum时，它将更改For Each的内容。但是，实际上并不是replaceVal()循环的所在。结果，GetEnumerator在迭代一个集合时正在对其进行修改。 VB.NET docs对此话题有话要说。我怀疑VB.NET的行为是从VBA继承的，因为它与您所看到的匹配。具体来说：
由{{1}的
System.Collections.IEnumerable返回的枚举数对象通常不允许您通过添加，删除，替换或重新排序任何元素来更改集合。如果在启动For Each...Next循环之后更改集合，则枚举器对象将变为无效...
因此，您可能必须推出自己的IEnumerator实现，而不是从Collection重用。
编辑，我发现this link建议您实现IEnumVARIANT，这是VBA本身无法实现的（编辑，但可以如上所示！）。我还没有亲自尝试过该链接上的信息，但是将其传递给我们以防不便。