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

Question

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

Gre*_*edo 6 excel foreach enums vba excel-vba

在VBA中,如果你想要一个迭代Range像Python对象,你做的东西像这样.然而,这种方法涉及一次性构建整个范围:

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

Run Code Online (Sandbox Code Playgroud)

...如果你想要制作一个非常大的范围,这是很糟糕的,因为它需要很长时间和很多内存来构建该集合.这就是发电机的用途; 它们在循环时生成序列中的下一个项目.

现在,如果您希望一个类可以迭代,它必须返回一个[_NewEnum],这是通过Set关键字完成的.这告诉我一个For...Each循环只需要引用一个Enum,因为Set关键字只分配指向返回变量的指针,而不是实际值.

这为一些杂耍提供了空间:

For...Each(此后称为"迭代器")需要一些内存来指示所提供的内容[_NewEnum]; 枚举对象指针的引用
自定义类可以随时[_NewEnum]从封装的集合生成指针
也许因此,如果类知道Iterator在内存中寻找枚举指针的位置,它可以用指向不同枚举对象的指针覆盖该位内存.

换一种说法:

在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

Run Code Online (Sandbox Code Playgroud)

包含一个标准方法,可以一次性完成整个过程,或者一个生成器方法,与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

Run Code Online (Sandbox Code Playgroud)

最后一行是重要的一行; 它说要将提供的对象的对象指针复制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

Run Code Online (Sandbox Code Playgroud)

如果它正在工作那么这应该打印数字1到10.但是现在它一下子就退出了循环.

那么为什么这不起作用呢？我想我已经按照我概述的所有步骤进行了操作.我认为内存更新程序正在按预期工作,但我不确定,因为我无法查询ObjPtr()Iterator当前使用的枚举.也许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

Run Code Online (Sandbox Code Playgroud)

Answer 1

cxw*_*cxw 6

如何解决它

一个严重名为1337的黑客DEXWERX写了魔渊在2017年我适应DEXWERX代码这一情况,并在这里提供一个工作的例子.这些作品是:

MEnumerator:DEXWERX代码的调整版本.这使得IEnumVARIANT它从头开始在内存中组装!
IValueProvider:您的生成器应实现的直接VBA接口.在IEnumVARIANT通过创建MEnumerator将调用一个方法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

Run Code Online (Sandbox Code Playgroud)

`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

Run Code Online (Sandbox Code Playgroud)

`NumberRange.cls`

将其保存到文件并将其导入VBA编辑器.请注意,该NewEnum函数现在只是委托给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

Run Code Online (Sandbox Code Playgroud)

`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

Run Code Online (Sandbox Code Playgroud)

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

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

您正在导出一个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

Run Code Online (Sandbox Code Playgroud)

此代码打印1然后退出For Each循环.

我相信这个updateObject电话没有按你的意愿行事.以下是基于我自己的知识,也是这个论坛的帖子.当For Each循环开始,VBA得到一个IUnknown从_NewEnum.然后QueryInterface,VBA调用它IUnknown来获取自己的IEnumVARIANT指针,指向单个引用计数的枚举器对象.因此,它For Each有自己的枚举器副本.

然后,当你打电话时updateObject,它改变了内容this.currentEnum.但是,这不是For Each循环实际看的地方.因此,replaceVal()在迭代过程中修改集合.在VB.NET文档有话要对这个问题说了.我怀疑VB.NET的行为是从VBA继承而来的,因为它符合你所看到的.特别:

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

因此,您可能必须滚动自己的IEnumerator实现而不是重用它Collection.

编辑我发现这个链接暗示你需要实现IEnumVARIANT,哪个VBA本身不会做(编辑但可以做,如上所示!).我自己没有在那个链接上尝试过这些信息,但是如果它有用的话就把它传递给我.

归档时间：	7 年前
查看次数：	199 次
最近记录：	7 年前

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

发电机:NumberRange类模块

内存管理助手模块

测试代码

如何解决它

测试代码

IValueProvider.cls

NumberRange.cls

MEnumerator.bas

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

发电机:`NumberRange`类模块

`IValueProvider.cls`

`NumberRange.cls`

`MEnumerator.bas`