Реализовать Python-подобный генератор с помощью пользовательского перечислителя в VBA

Question

В VBA, если вы хотите итеративный объект Range, как в Python, вы делаете что-то вроде this .Однако этот подход предполагает построение всего диапазона за один раз:

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

... что плохо, если вы хотите создать действительно большой диапазон, так как для этого требуются годы и многопамяти, чтобы построить эту коллекцию.Вот для чего нужны генераторы;они генерируют следующий элемент в последовательности во время цикла.

Теперь , если вы хотите, чтобы класс был итеративным , он должен вернуть [_NewEnum], что делается с помощью Set ключевое слово.Это говорит мне о том, что для цикла For...Each требуется только ссылка на Enum, поскольку ключевое слово Set только назначает указатели на возвращаемую переменную, а не на фактическое значение.

Это дает возможность немного жонглировать:

• For...Each (далее "Итератор") требует немного памяти, которая дает указания для поставляемого [_NewEnum];ссылка на указатель объекта enum
• Пользовательский класс может генерировать указатель [_NewEnum] из инкапсулированной коллекции всякий раз, когда он хочет
• Возможно, поэтому, если класс знает, где в памяти ищет Итератордля указателя перечисления он может полностью перезаписать этот бит памяти указателем на другой объект перечисления.

Другими словами:

• В первой итерацииFor...Each цикл, мой класс возвращает переменную , значением которой является указатель на один Enum.Переменная находится в памяти в месте, заданном VarPtr(theVariable)
• . На следующей итерации я вручную вызываю метод моего класса, который генерирует второе значение Enum
• . После этого метод продолжает перезаписыватьуказатель первого объекта перечисления на адрес, указанный указателем переменной, и заменяет его на ObjPtr() из второго перечисления.

Если эта теория верна, то цикл For Each теперь будет выполнятьсяссылка на другое значение для [_NewEnum], поэтому будет делать что-то другое.

---

Вот как я пытался это сделать:

Генератор: NumberRange Класс Module

Примечание: должен быть импортирован для сохранения атрибутов.

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 просто не нравится, когда его прерывают!Любые мысли о том, как добиться желаемого поведения, приветствуются!

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

Answer 1

Как это исправить

A серьезно 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

IValueProvider.cls

Сохраните это в файл и импортируйте его в VBA Editor.

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 и 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 для собственного использования.Прямая 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, VBA получает IUnknown от _NewEnum.Затем VBA вызывает QueryInterface для IUnknown, чтобы получить собственный указатель IEnumVARIANT на один объект перечислителя с подсчетом ссылок.В результате у For Each есть собственная копия перечислителя.

Затем, когда вы звоните updateObject, он изменяет содержимое this.currentEnum.Однако, это не то, где цикл For Each фактически смотритВ результате replaceVal() изменяет коллекцию, пока она повторяется.В VB.NET документах есть что сказать по этому вопросу.Я подозреваю, что поведение VB.NET было унаследовано от VBA, поскольку оно соответствует тому, что вы видите.В частности:

Объект перечислителя, возвращаемый GetEnumerator [из System.Collections.IEnumerable], обычно не позволяет изменять коллекцию путем добавления, удаления, замены или переупорядочения любых элементов.Если вы измените коллекцию после того, как вы запустили цикл For Each...Next, объект перечислителя станет недействительным ...

Поэтому вам, возможно, придется свернуть собственную реализацию IEnumerator, а не использовать ее повторно изCollection.

Редактировать Я нашел эту ссылку , предлагая вам реализовать IEnumVARIANT, что VBA не будет делать изначально ( edit но можно сделать, как показано выше!).Я сам не пробовал информацию по этой ссылке, но передал ее на случай, если она окажется полезной.