在 VBA 中使用自定义枚举器实现类 Python 生成器

Question

在 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 的引用，因为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。但现在它一次就退出了循环。

那么为什么这不起作用？我想我已经遵循了我概述的所有步骤。我认为内存更新程序正在按预期工作，但我不确定，因为我无法查询迭代器当前正在使用的枚举的 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

Answer 1

如何解决

认真 2017 年，一位名叫 DEXWERX 的 1337 黑客写了 deep magic。我根据这种情况调整了 DEXWERX's code，并在此处提供了一个工作示例。这些部分是：

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

以下是要粘贴到 VBA 中的测试代码，以及要导入的 cls 和 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 函数现在仅委托给MEnumerator 中的NewEnumerator 函数。这不是使用集合，而是覆盖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.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

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

我不能告诉你如何解决它，但是我可以告诉你为什么。评论太长了:)。

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

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 调用没有达到您的预期。以下是根据我自己的知识，还有this forum post。当For Each 循环开始时，VBA 从_NewEnum 获得一个IUnknown。 VBA 然后在IUnknown 上调用QueryInterface 以将其自己的IEnumVARIANT 指针指向单个的、引用计数的枚举器对象。因此，For Each 拥有自己的枚举数副本。

然后，当您调用updateObject 时，它会更改this.currentEnum 的内容。然而，这并不是For Each 循环真正关注的地方。因此，replaceVal() 在迭代时正在修改集合。 VB.NET docs 对此话题有话要说。我怀疑 VB.NET 的行为是从 VBA 继承的，因为它与您所看到的相符。具体来说：

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

因此，您可能必须推出自己的 IEnumerator 实现，而不是重复使用来自 Collection 的实现。

编辑我发现this link 建议您需要实现IEnumVARIANT，VBA 本身不会这样做（编辑，但可以这样做，如如上所示！）。我自己没有尝试过该链接上的信息，但请传递它以防万一。