代码之家 › 专栏 › 技术社区 › Greedo

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

enums foreach excel-vba vba excel

6

Greedo · 技术社区 · 6 年前

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 ,自从 套 关键字只将指针分配给返回的变量,而不是实际值。

这就给了我们一些机会:

(从今以后称为“迭代器”)需要一位内存来向所提供的 [\u新枚举]
自定义类可以生成 [\u新枚举] 随时从封装的集合中获取指针
因此,如果类知道迭代器在内存中查找枚举指针的位置,它就可以用指向不同枚举对象的指针覆盖内存位。

换句话说:

在循环,我的类返回变量其值是指向一个枚举的指针。变量驻留在内存中的以下位置 VarPtr(theVariable)
在下一次迭代中,我手动调用类的一个方法,该方法生成第二个枚举
之后,该方法继续覆盖变量指针给定地址处的第一个枚举对象指针,并用 ObjPtr() 第二个枚举的。

For Each [\u新枚举] 所以我会做一些不同的事情。

发电机: `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

内存管理辅助模块

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

为什么这不起作用?我想我已经遵循了我概述的所有步骤。我认为内存更新程序按预期工作,但我不确定,因为我无法查询 ObjPtr() 迭代器当前使用的枚举的。也许 为…每个 只是不喜欢被打扰!任何关于如何实现期望行为的想法欢迎!

另外,经常储蓄,小心撞车!

内存写入程序的附加测试方法:

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

1 回复 | 直到 6 年前

1

6

cxw 6 年前

如何修复

A 认真地 1337名黑客 DEXWERX deep magic 2017年。我适应了 DEXWERX's code

MEnumerator :DEXWERX代码的调整版本。这是个好主意 IEnumVARIANT 把它从零开始组装在记忆里!
IValueProvider IEnumVARIANT公司 菜单器 IValue提供商 实例以获取要返回的元素。
NumberRange :生成器类,它实现 IValue提供商

下面是要粘贴到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 功能现在仅委托给 NewEnumerator 中的函数 . 它不使用集合,而是覆盖 IValueProvider_HasMore 和 IValueProvider_GetNext 使用方法 菜单器 .

还要注意的是,为了保持一致性,我将所有内容都设为零。

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`

IEnumVARIANT_Next 呼叫 IValue提供商 方法并将其转发到VBA。这个方法构建 .

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 具有相同的行为:

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 . 当循环开始,VBA得到 IUnknown _NewEnum . 然后VBA调用 QueryInterface 我不知道 为了得到它自己的 IEnumVARIANT公司 对于每个

,它改变了 this.currentEnum . 然而,这并不是 对于每个 replaceVal() VB.NET docs 在这个问题上有话要说。我怀疑VB.NET版是从VBA继承的,因为它与您看到的内容匹配。明确地:

返回的枚举器对象 GetEnumerator [共 System.Collections.IEnumerable ]通常不允许通过添加、删除、替换或重新排序任何元素来更改集合。如果在启动 For Each...Next

因此,你可能要自己滚 IEnumerator 收藏 .

编辑 this link 建议您需要实施 ,这是VBA本机无法完成的(

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

发电机: NumberRange 类模块