User Tools

Site Tools


vba:classes:iterator:index

[VBA] Iterator

Eine Iterator-Klasse um die verschiedenen Listenmöglichkeiten (Array, Collection, Dictioary etc.) alle gleich handhaben zu können

Version 2.8.0 11.01.2016
Das Modul hat versteckte Attribute. Damit diese aktiv übernommen werden reicht es nicht aus, den Code in ein neues Modul zu kopieren. Man muss das Modul aus der Datei nach VBA importieren.
Bild zum Import

Download iterator.cls (V-2.8.0)

In VBA gibt es verschiedene Listen-Arten. Array, Collection und Dictionary. Wenn man noch mit RegExp arbeitet kommen MatchCollection und Match.Submatches dazu. Bei Recordset die Fields.

Jeder dieser Listen muss anderst behandelt werden. Mal beginnen die Indexe irgendwo (array), mal bei 1 (Collection), meistens bei 0 oder im Fall von Dictionaries muss man über den Key zugriffen werden.

Ich wollte ein einheitliches Konstrukt, durch dass ich bequem mittels Loop durchiterieren kann. Dabei kam die Iterator-Klasse heraus.

Am besten mal die Anwendungsbeispiele anschauen um zu verstehen um was es geht.

Die folgenden Listen sind ausprogrammiert:
Array, Collection1), Dictionary2), RegExp.MatchCollection3), RegExp.Submatches, DAO.Recordset, DAO.Fields DAO.QueryDef DAO.TableDef Excel.Workbook (Die Sheets) Excel.Sheets FSO.Folder

Definitionen

Enumerator

itParams

'/**
' * Parameter zur Steuerung des Verhalten des Iterators
' * Die einzelnen Parameter sind mit + kombinierbar
' */
Public Enum itParams
    itNone = 0                          'Kein Parameter hat gültigkeit
    itNothingAsEmptyList = 2 ^ 0        'Leerer String, Nothing, Empty, Null wird als leere Liste akzeptiert und wirft kein Fehler
    itListNextNoParamsAsToNext = 2 ^ 1  'Wenn bei listNext keine Parameter angeben werden, einfach eins vorrücken.
    itErrorAtEmptyList = 2 ^ 2          'Fehler generieren, wenn die iListe leer ist
    itDaoValue = 2 ^ 3                  'Field-Value anstelle von Field ausgeben
    itIndexInsteadKey = 2 ^ 4                     'Gibt bei den toX() Funktionen den Index anstelle des Keys zurück
    itDefault = itNothingAsEmptyList + itListNextNoParamsAsToNext
    [_LAST] = 4
End Enum

Properties

Die Eigenschaften der Klasse.
r steht für Readable, w für writable

Properties zu den Daten

  • sourcerw Quellliste, über die Iteriert wird (Array, Collection etc.)
  • currentr Aktuelles Item
  • keyr Aktueller Key
  • indexr Aktueller Indes der Liste, beginnend mit dem listenspezifischen Anfang
  • absolutePositionr Absolute Position in der Liste, beginnend mit 0
  • BOFr Beginn of File. Wir sind vor dem ersten Eintrag
  • EOFr End of File. Wir sind nach dem letzten Eintrag
  • countr Anzahl Items in der Liste
  • isEmptyr Flag, ob überhaubt Einträge vorhanden sind: count=0

Propierties zur Iteratorsteuerung

Diese Properties sind die Einzeilzuordnungen zu itparams

  • Paramsrw Die Parameter als Enum-Set
  • paramNothingAsEmptyListrw Leerer String, Nothing, Empty, Null wird als leere Liste akzeptiert und wirft kein Fehler
  • paramListNextNoParamsAsToNextrw Wenn bei listNext keine Parameter angeben werden, einfach eins vorrücken.
  • paramErrorAtEmptyListrw Fehler generieren, wenn die iListe leer ist
  • paramDaoValuerw Field-Value anstelle von Field ausgeben
  • paramIndexInsteadKeyrw Gibt bei den toX() Funktionen den Index anstelle des Keys zurück

Methoden

Collection Class Methodes

Diese Funktionen dienesn dazu, dass die Klasse wie eine Collection genutzt werden kann.
http://msdn.microsoft.com/en-us/library/aa262338%28v=vs.60%29.aspx

NewEnum()
'/**
' * Der NewEnum wird für die For Each.. Next Schleife verwendet
' *
' * Diese Funktion hat das Attribut "'Attribute NewEnum.VB_UserMemId = -4"
' * !! Diese Iterierung hat keinen Einfluss auf die aktuelle Position !!
' *
' * @return Das nächste element
' */
Public Function NewEnum() As IUnknown
item()
'/**
' * Entspricht dem item()-Befehl der Listenobjekte
' * Alle 3 Propert-Funktionen aben das versteckte Attribut "Attribute item.VB_UserMemId = 0"
' * Dadurch kann mittels it(1), it("MyFeild"), it!MyField etc darauf zugegriffen werden.
' *
' * !! Das Verhalten dieser Funktion ist NICHT standartisiert. Sie entspricht dem entsprechenden Verhalten der Source !!
' *
' * @param  Variant Index/Key
' * @return Variant
' */
Public Property Get item(ByVal iIndex As Variant) As Variant

Initialisierungs-Methoden

initialize()
'/**
' * Initialisuert den Iterator
' * @param  Variant     Die Liste, über welche Iteriert werden soll
' * @param  itParams    Parameters
' * @return Boolean     true: iList ist eine Liste und hat Werte
' */
Public Static Function initialize( _
        ByRef iList As Variant, _
        Optional ByVal iParams As itParams = itDefault _
) As Boolean
initializeRs()

Die Parameters findest du hier. Sie sind mit + kombinierbar.

'/**
' * Analog zu initialze. Erstellt aber direkt ein Recordset aus einem SQL
' * @param  String      SLQ String
' * @param  itParams    Parameters
' * @return Boolean     true: iList ist eine Liste und hat Werte
' */
Public Static Function initializeRs( _
        ByVal iSql As String, _
        Optional ByVal iParams As itParams = itDefault _
) As Boolean
toNext()
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toNext( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
toPrev()
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toPrev( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
toFirst()
'/**
' * Geht zum ersten Datensatz.
' * Vorsicht, während reset() eins vor den ersten Datensatz geht, geht toFirst() bereits auf den ersten Datensatz
' * Somit ists das eigentlich reset()+toNext()
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toFirst( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
toLast()
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toLast( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
toPosition()
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Long        Absolute Position. Zwischen 0 und Count-1
' * @param  Variant     Key oder index des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toPosition( _
        ByVal iAbsolutPosition As Long, _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
listNext()

Siehe auch [VBA] list()

'/**
' * Rückt den Zeiger um Eins vor und gibt die Elemente einer Unterliste aus.
' * @paramArray Variant    Auflistung der Variablen, die abgefüllt werden
' * @return     EOF
' */
Public Function listNext( _
        ParamArray oParams() As Variant _
) As Boolean
list()

Siehe auch [VBA] list()

'/**
' * Ggibt die Elemente der aktuellen Unterliste aus.
' * @paramArray Variant    Auflistung der Variablen, die abgefüllt werden
' * @return EOF & BOF
' */
Public Function list( _
        ParamArray oParams() As Variant _
) As Boolean
reset()
'/**
' * Setzt den pos auf den Start-1 zurück, so dass bei einem toNext() der erste Datensatz kommt
' */
Public Sub reset()
subIterator()

Wenn das Current-Objekt selber wieder iterierbar ist, kann mit dieser Methode direkt ein Iterator für das Objekt erstellt werden.

'/**
' * Gibt current als Iterator zurück
' * @return Iterator
' */
Public Property Get subIterator() As Iterator

Iterierbare Listen

Die folgenden Datentypen werden vom Iterator als Liste erkannt und können iteriert werden

  • Array
  • Dictionary
  • Collection
  • RegExp.MatchCollection
  • RegExp.Match
  • Dao.Recordset
  • Dao.Fields
  • Dao.Field
  • Properties

Anwendungsbeispiele

Die Beispiele sind unvollständig. Die Klasse hat noch einiges mehr auf Lager. Finde es heraus oder frag nach.

Iteration mit einem eindimensionalen Array

Einfachstes Beispiel mit einem Array

Public Sub testIt()
    Dim arr()   As Variant:         arr = Array(1, 2, 3)
    Dim it      As New Iterator:    it.initialize arr
 
    Do While it.toNext
        Debug.Print it.key & ": " & it.current
    Loop
End Sub

Dito, aber der Wert wird als Variable verarbeitet

Public Sub testIt()
    Dim arr()   As Variant:         arr = Array(1, 2, 3)
    Dim it      As New Iterator:    it.initialize arr
    Dim key     As Variant
    Dim val     As Variant
 
    Do While it.toNext(key, val)
        Debug.Print key & ": " & val
    Loop
End Sub

Von hinten nach vorne iterieren

Public Sub testIt()
    Dim arr()   As Variant:         arr = Array(1, 2, 3)
    Dim it      As New Iterator:    it.initialize arr
 
    it.toEOF
    Do While it.toPrev
        Debug.Print it.KEY & ": " & it.current
    Loop
End Sub

Und ein Array, der nicht bei 0 beginnt

Public Sub testIt()
    Dim arr(3 To 4)   As Variant
    Dim it      As New Iterator
    Dim key     As Variant
    Dim val     As Variant
 
    arr(3) = 33
    arr(4) = 44
    it.initialize arr
 
    Do While it.toNext(key, val)
        Debug.Print key & ": " & val
    Loop
End Sub

Iteration über einen 2 Dimensionalen Array

Mit direktem Auslesend er SubItems mit listNext()

Public Sub testIt()
    Dim arr(3 To 4)   As Variant
    Dim it      As New Iterator
    Dim v1, v2, v3
 
    arr(3) = Array(31, 32, 33)
    arr(4) = Array(41, 42, 44)
    it.initialize arr
 
    Do While it.listNext(v1, v2, v3)
        Debug.Print v1 & "-" & v2 & "-" & v3
    Loop
End Sub
31-32-33
41-42-44

Besipel mit MatchCoellection

Public Sub testIt()
    Dim rx  As New regExp
    Dim mc  As Variant
    Dim it  As Iterator
    Dim x, y
 
    rx.Global = True
    rx.pattern = "([A-H])([1-8])"
 
    Set mc = rx.execute("Springer von A1 auf B3")
    Set it = New Iterator: it.initialize mc
    Do While it.toNext
        Debug.Print it.current.value    'Den gesamten gefunden String ausgeben
        it.list x, y                    'Die 2 Submatches auf x und y verteilen
        Debug.Print x & ":" & y         'x & y ausegeben
    Loop
End Sub
A1
A:1
B3
B:3

Beispiele zu Recordset

Recordset durchiterieren

Public Sub testIt()
    'Initialiseren des Iterators über initializeRs
    Dim it As New Iterator: it.initializeRs "SELECT [id], [number_one], [number_two] FROM [_test]"
 
    'Jede ID ausgeben
    Do While it.toNext
        Debug.Print it!id
    Loop
 
    it.reset    'Postion zurücksetzen
    
    'Die Felder des Recordsets direkt in die Variablen übertragen
    Dim id, n1, n2
    Do While it.listNext(id, n1, n2)
        Debug.Print id, n1, n2
    Loop
 
End Sub
 1 
 2 
 3 
 4 
 1             11            21 
 2             12            22 
 3             13            23 
 4             14            24

FieldList durchiterieren - Ausgabe von current und value

Public Sub testIt()
    Dim v As Variant
 
    'Initialiseren des Iterators über initializeRs
    Dim it As New Iterator: it.initializeRs "SELECT [id], [number_one], [number_two] FROM [_test]"
 
    'Erste Zeile als [Fields] auslesen und neuen Iterator daruas erstellen
    it.toFirst
    Dim itFields As Iterator: Set itFields = it.subIterator
 
    Debug.Print "== Ausgabe: Property current"
    Do While itFields.toNext
        print_r itFields.current
    Loop
 
    Debug.Print "== Ausgabe: Property value"
    itFields.reset                  'position zurücksetzen
    Do While itFields.toNext
        print_r itFields.value
    Loop
 
    Debug.Print "== Ausgabe: Referenziertes Property current, Iterator mit dem Parameter DaoValue"
    itFields.reset                  'position zurücksetzen
    itFields.paramDaoValue = True   'Paraeter DaoValue setzen um das Verhalten von current zu ändern
    Do While itFields.toNext(, v)   'Der zweite Parameter von toNext() entspricht dem current
        print_r v
    Loop
 
End Sub
== Ausgabe Property current
<Field2>  (
    [OrdinalPosition] => <Integer> 0
    [name] => <String> 'id'
    [value] => <Long> 1
    [type] => <Integer> 4
)
<Field2>  (
    [OrdinalPosition] => <Integer> 1
    [name] => <String> 'number_one'
    [value] => <Long> 11
    [type] => <Integer> 4
)
<Field2>  (
    [OrdinalPosition] => <Integer> 2
    [name] => <String> 'number_two'
    [value] => <Long> 21
    [type] => <Integer> 4
)
== Ausgabe Property value
<Long> 1
<Long> 11
<Long> 21
== Ausgabe Property current, Iterator mit dem Parameter DaoValue
<Long> 1
<Long> 11
<Long> 21

Code

iterator.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Iterator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------
'File         : Iterator.cls
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iterator
'Environment  : VBA 2007+
'Version      : 2.8.0
'Name         : Iterator
'Author       : Stefan Erb (ERS)
'History      : 28.02.2014 - ERS - Creation
'               ...
'               27.02.2015 - ERS - instance() und itKeyIgnoreCase hinzugefügt
'               02.09.2015 - ERS - QueryDef und TableDaef als Liste hinzugefügt. Sie werden als Recordset gehandelt
'               11.01.2016 - ERS - Aliase zu den toX() Vefehlen hinzugefügt, die den Iterator zurückgeben

'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------
'/**
' * In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht.
' * Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable
' * Es gibt auch Codeabschnitte die nur in Access (oder mit einer Referenz auf Access) funktionieren
' */
#Const isAccess = True
 
'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------
'/**
' * Parameter zur Steuerung des Verhalten des Iterators
' * Die einzelnen Parameter sind mit + kombinierbar
' */
Public Enum itParams
    itNone = 0                          'Kein Parameter hat gültigkeit
    itNothingAsEmptyList = 2 ^ 0        'Leerer String, Nothing, Empty, Null wird als leere Liste akzeptiert und wirft kein Fehler
    itListNextNoParamsAsToNext = 2 ^ 1  'Wenn bei listNext keine Parameter angeben werden, einfach eins vorrücken.
    itErrorAtEmptyList = 2 ^ 2          'Fehler generieren, wenn die iListe leer ist
    itDaoValue = 2 ^ 3                  'Field-Value anstelle von Field ausgeben
    itIndexInsteadKey = 2 ^ 4           'Gibt bei den toX() Funktionen den Index anstelle des Keys zurück
    itNotOverwriteMap = 2 ^ 5           'Überschreibt den Iterator nicht, wenn dieser bereits initialisiert ist.
    itKeyIgnoreCase = 2 ^ 6             'IgnoriertGross/Kleinschreibungder keys.
    itDefault = itListNextNoParamsAsToNext + itKeyIgnoreCase
End Enum
 
'/**
' * Information, ob sich der Iterator gerade in einem Loop befindet und wenn ja, in welche Richtung
' * Steuert das verhalten bei remove()
' */
Public Enum itLoopDirection
    itDefaultDirection = 0
    itDirect = 2 ^ 0
    itToNext = 2 ^ 1
    itToPrev = 2 ^ 2
End Enum
 
'/**
' * Typ des Keys/Index
' */
Public Enum itKeyType
    itDefaultKeyType = 0
    itIndex = 2 ^ 0
    itKey = 2 ^ 1
    itAbsolutePosition = 2 ^ 2
End Enum
 
'/**
' * Enum ADODB.PositionEnum
' * Hier gespiegelt, falls ADODB nicht referenziert ist
' */
Public Enum PositionEnum
    adPosUnknown = -1
    adPosBOF = -2
    adPosEOF = -3
End Enum
 
'/**
' * Public Event, wenn EOF erreicht wird
' */
#If isAccess Then
    Public Event arriveEndOf(pos As PositionEnum)
#End If
 
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------
Private Const IT_ERR_NO_PARAMS = vbObjectError + 5000           'Bei einer list-Funktion wurden keine Parameter übergeben
Private Const IT_ERR_NOT_SUPPORTED_MAP = vbObjectError + 5001   'Ist keine bekannte Liste
Private Const IT_ERR_EMPTY_MAP = vbObjectError + 5002           'Die Liste ist leer
Private Const IT_ERR_KEY_NOT_FOUND = vbObjectError + 5003       'Der angegebene Key wurde nicht in der Liste gefunden
Private Const IT_ERR_DUPLICATE_KEY = vbObjectError + 5004
Private Const IT_ERR_MISSING_KEY = vbObjectError + 5005
 
 
'/**
' * Interne Typenunterscheidung der Liste
' */
Private Enum itListType
    itArray
    itDictionary
    itCollection
    itMatchCollection
    itMatch
    itQueryDef
    itTableDef
    itDaoRecordset
    itDaoFields
    itDaoField
    itProperties
    itNoList
    itExcelWoorkbook
    itExcelSheets
    itFSOFolder
    itFSOFolders
    itSqlString
End Enum
 
Private Enum baValueType
    baBitPosition = 1       'Der Array-Value beinhaltet die Bitpositionen von allen gesetzten Bit. Bei nicht gesezten Bits ist der Value false (also -1)
    baBit = 2               'Gibt das Bit an der entsprechenden Position zurück. 0 oder 1
    baValue = 3             'Gibt den Wert des Bits zurück: 2^Bitposition
End Enum
 
Private Enum incType
    itPreIncrement = 0    '++1
    itPostIncrement = 1   'i++
    itPreDecrement = 2    '--i
    itPostDecrement = 3   'i--
End Enum
 
Private map                         As Variant      'Die Liste selber
Private uKeys                       As Dictionary   'Übersetzun der Keys. Dict(KEY := Key)
Private forEachCollection           As Collection   'Für den ForEach braucht es leider einse Collection-Class
Private listType                    As itListType   'Typ der Liste
Private pos                         As Long         'Absolute Position, beginnend bei 0
Private myKeys()                    As Variant      'Auflistung der Keys. Wird nur bei Dictionaries, DAO.Fields und Properties gebraucht
Private delta                       As Long         'Index-Abweichung des ersten Indexes zu 0: Index = pos + delta
Private Cnt                         As Long         'Anzahl Einträge
Private myParams                    As itParams     'Parameters
Private loopDirection               As itLoopDirection
Private keyType                     As itKeyType
Private flagIsInitialized           As Boolean
 
'-------------------------------------------------------------------------------
' -- COLLECTION METHODES ---
' http://msdn.microsoft.com/en-us/library/aa262338%28v=vs.60%29.aspx
'-------------------------------------------------------------------------------

'/**
' * Der NewEnum wird für die For Each.. Next Schleife verwendet
' *
' * Diese Funktion hat das Attribut "'Attribute NewEnum.VB_UserMemId = -4"
' * !! Diese Iterierung hat keinen Einfluss auf die aktuelle Position !!
' *
' * @return Das nächste element
' */
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
'Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = forEachCollection.[_NewEnum]
End Function
 
 
'/**
' * Entspricht dem item()-Befehl der Listenobjekte ode dem instance() der Klasse.
' * Alle 3 Propert-Funktionen aben das versteckte Attribut "Attribute item.VB_UserMemId = 0"
' * Dadurch kann mittels it(1), it("MyFeild"), it!MyField etc darauf zugegriffen werden.
' *
' * !! Das Verhalten dieser Funktion ist NICHT standartisiert. Sie entspricht dem entsprechenden Verhalten der Source !!
' *
' *     node = it(index)
' *     node = it(key)
' *     node = it!key
' *     node = it.item(index)
' *     node = it.item(key)
' *     iterator = Iterator(Recordset/Array etc.)
' *
' * @param  Variant Index/Key
' * @return Variant Value/Iterator
' */
Public Property Get item(ByVal iIndex As Variant) As Variant
Attribute item.VB_UserMemId = 0
'Attribute item.VB_UserMemId = 0
    'Falls noch keine Liste Initialisiiert ist, dann gilt der Aufruf als Iterator.instance
    If Not isInitialized Then
        Set item = Iterator.instance(iIndex)
        Exit Property
    End If
 
    Select Case listType
        Case itDaoFields, itDaoRecordset:       'Bei FieldListen je nach Parameter das Field oder den Value ausgeben
            ref item, IIf((myParams And itDaoValue), map(iIndex).value, map(iIndex))
        Case itDictionary:                      'Bei Dictionaries über den Key zugreiffen
            If IsNumeric(iIndex) Then
                ref item, map(myKeys(iIndex))
            ElseIf Params And itKeyIgnoreCase Then
                ref item, map(uKeys(UCase(iIndex)))           'Dictionary mit Keys.
            Else
                ref item, map(iIndex)
            End If
        Case Else:
            ref item, map(iIndex)
    End Select
End Property
 
'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------
Public Function instance( _
        ByRef iList As Variant, _
        Optional ByVal iParams As itParams = itDefault _
) As Iterator
    Set instance = New Iterator
    instance.initialize iList, iParams
End Function
 
'/**
' * Initialisuert den Iterator
' * @param  Variant     Die Liste, über welche Iteriert werden soll
' * @param  itParams    Parameters
' * @return Boolean     true: iList ist eine Liste und hat Werte
' */
Public Function initialize( _
        ByRef iList As Variant, _
        Optional ByVal iParams As itParams = itDefault _
) As Boolean
 
On Error GoTo Err_Handler
 
    If flagIsInitialized And (iParams And itNotOverwriteMap) <> 0 Then Resume Exit_Handler
 
    Me.Params = iParams
 
    'Art der Liste ermitteln
    listType = getListType(iList)
    'Spezialfälle
    If listType = itNoList And Me.paramNothingAsEmptyList Then  'Leer -> Leerer Array
        iList = Array()
    ElseIf listType = itNoList Then                             'Leer -> Fehler
        Err.Raise IT_ERR_NOT_SUPPORTED_MAP, "initialize", "Unknow List type: " & TypeName(iList)
#If isAccess Then
    ElseIf listType = itSqlString Then                          'String -> DAO.Recodset mit iList als SQL
        Dim db  As DAO.Database:    Set db = CurrentDb
        Set iList = CurrentDb.OpenRecordset(iList, dbOpenSnapshot, dbReadOnly)
        listType = itDaoRecordset
        Set db = Nothing
    ElseIf listType = itQueryDef Or listType = itTableDef Then                          'String -> DAO.Recodset mit iList als SQL
        Set iList = iList.OpenRecordset
        listType = itDaoRecordset
#End If
    End If
 
    ref map, iList                      'Liste übernehmen
    delta = 0                           'Index = AbsolutPosition + delta

SPEZ:
    'Spezialsettings der einzelnen ListenTypen
    Select Case listType
        'Array: Der Delta muss je nach lbound() angepasst werden
        Case itArray:
            On Error Resume Next
            delta = LBound(map)         'Der Array beginnt bei lbound(list) zu zählen
            If Err <> 0 Then delta = 0
            Err.clear
            On Error GoTo Err_Handler
        'Collection: Die Collection beginnt bei 1 mit Zählen
        Case itCollection:      delta = 1
        'Match: Bei Matches ist die Liste im Attribut SubMatches versteckt. Der Rest vom Match interessiert uns nicht weiter
        Case itMatch:           ref map, iList.subMatches
        'Field: Bei einem Field interessieren uns die Properties
        Case itDaoField:
            listType = itProperties                         'ListType als itProperties setzen
            ref map, iList.properties                       'Properties als map übernehmen
            GoTo SPEZ                                       'Die Definition für itProperties übernhemen
        'Excel Workbook: Die Sheets extrahieren
        Case itExcelWoorkbook:
            listType = itExcelSheets                        'WorkSheet als Sheets setzen
            ref map, iList.Sheets                           'Sheets als map übernehmen
            GoTo SPEZ                                       'Die Definition für itExcelSheets übernhemen
        'Folder: Bei einem Folder interessieren die SubFolders und die Files
        Case itFSOFolder:
            listType = itCollection
            Set map = New Collection
            Dim f As Object: For Each f In iList.SubFolders
                map.add f
            Next
            For Each f In iList.Files
                map.add f
            Next
            GoTo SPEZ
        'Folders: Eine Liste von Folders. zB aus SubFolders(). Da man nicht über Index auf die einzelnen Folder zugreiffen kann, das ganze in eine Collection schreiben
        Case itFSOFolders
            listType = itCollection
            Set map = New Collection
            Dim sf As Object: For Each sf In iList
                map.add sf
            Next
            GoTo SPEZ
        'Dictionary: Das Dictionary clonen
        Case itDictionary:
            Set uKeys = CreateObject("scripting.Dictionary")
            Dim KEY As Variant: For Each KEY In map.keys
                uKeys.add UCase(KEY), KEY
            Next KEY
        'BEid en ExcelSheets das Dleta um eins versetzen
        Case itExcelSheets:     delta = 1
        Case itNoList:          Err.Raise IT_ERR_NOT_SUPPORTED_MAP, "Iterator.init", "Parameter is not a supported map"
    End Select
 
    Cnt = Count                         'Count  speichern
    createKeyList                       'Keys erstellen
    Call reset                          'Den Zeiger auf BOF setzen

    If Me.isEmpty And Me.paramErrorAtEmptyList Then Err.Raise IT_ERR_EMPTY_MAP, "Iterator.init", "Empty Map"
 
    recalcForEachCollection
 
    flagIsInitialized = True
    'initialize = Not Me.isEmpty

Exit_Handler:
    Exit Function
Err_Handler:
    Err.Raise Err.Number, Err.source, Err.description, Err.helpContext, Err.helpContext
    Resume Exit_Handler
    Resume
End Function
 
'/**
' * Initialisiert den Iterator und gibt gleich eine Referenz darauf zurück
' * @param  Variant     Die Liste, über welche Iteriert werden soll
' * @param  itParams    Parameters
' * @return Boolean     true: iList ist eine Liste und hat Werte
' */
Public Function create( _
        ByRef iList As Variant, _
        Optional ByVal iParams As itParams = itDefault + itNotOverwriteMap _
) As Iterator
    If Not flagIsInitialized Or (iParams And itNotOverwriteMap) = 0 Then initialize iList, iParams
    Set create = Me
End Function
 
'/**
' * Geht zum nächsten Datensatz. Der Key und der Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toNext( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    pos = pos + 1
    toNext = Not EOF:   If Not toNext Then raiseEndOf (adPosEOF): Exit Function
    keyOrIndex oKey
    getCurrent oItem
    loopDirection = itToNext
End Function
 
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toPrev( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    pos = pos - 1
    toPrev = Not BOF:   If Not toPrev Then raiseEndOf (adPosBOF): Exit Function
    keyOrIndex oKey
    getCurrent oItem
    loopDirection = itToPrev
End Function
 
'/**
' * Geht zum ersten Datensatz.
' * Vorsicht, während reset() eins vor den ersten Datensatz geht, geht toFirst() bereits auf den ersten Datensatz
' * Somit ists das eigentlich reset()+toNext()
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toFirst( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    pos = 0
    toFirst = Not EOF:   If Not toFirst Then raiseEndOf (adPosEOF): Exit Function
    keyOrIndex oKey
    getCurrent oItem
    loopDirection = itDirect
End Function
 
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toLast( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    pos = Cnt - 1
    toLast = Not BOF:   If Not toLast Then raiseEndOf (adPosBOF): Exit Function
    keyOrIndex oKey
    getCurrent oItem
    loopDirection = itDirect
End Function
 
'/**
' * Geht zu einer spezifischen Position (begnnt bei 0). Der Key und der Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Long        Absolute Position. Zwischen 0 und Count-1
' * @param  Variant     Key oder index des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toPosition( _
        ByVal iAbsolutPosition As Long, _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    pos = iAbsolutPosition
    toPosition = Not BOF And Not EOF
    If Not toPosition Then raiseEndOf (adPosUnknown): Exit Function
    keyOrIndex oKey
    getCurrent oItem
    loopDirection = itDirect
End Function
 
'/**
' * Geht zu einem spezifischen Key. Der Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder index des Items (je nach Item)
' * @param  Variant     Das Item himself
' * @return Boolean     EOF
Public Function toKey( _
        ByRef iKey As Variant, _
        Optional ByRef oItem As Variant = Null _
) As Boolean
    Dim pPos As Long
    'Die Position ermitteln
    Select Case listType
        Case itDictionary, itDaoFields, itProperties, itExcelWoorkbook:
            pPos = posFromKey(iKey)
        Case Else:
            pPos = iKey - delta
    End Select
    'Mittels toPosition zur Position springen
    toKey = toPosition(pPos, , oItem)
    getCurrent oItem
    loopDirection = itDirect
End Function
 
'/**
' * Rückt den Zeiger um Eins vor und gibt die Elemente einer Unterliste aus.
' * @paramArray Variant    Auflistung der Variablen, die abgefüllt werden
' * @return     EOF
' */
Public Function listNext( _
        ParamArray oParams() As Variant _
) As Boolean
    Dim aParams()   As Variant: aParams = oParams
 
 
    'Wenn keine Parameter übergeben werden, das ganze abbrechen.
    If UBound(oParams) = -1 And Not Me.paramListNextNoParamsAsToNext Then
        Err.Raise IT_ERR_NO_PARAMS, "Iterator.listNext", "no Parametes defined"
    End If
 
    listNext = toNext()
    listNext = listArray(aParams)
    If Not listNext Then Exit Function  'SubItem ist keine gültige Liste -> Exit
    Dim i As Long:  For i = 0 To UBound(oParams)
        If listType = itDaoRecordset And Me.paramDaoValue Then
            ref oParams(i), aParams(i).value
        Else
            ref oParams(i), aParams(i)
        End If
    Next i
    loopDirection = itDirect
End Function
 
'/**
' * Ggibt die Elemente der aktuellen Unterliste aus.
' * @paramArray Variant    Auflistung der Variablen, die abgefüllt werden
' * @return EOF & BOF
' */
Public Function list( _
        ParamArray oParams() As Variant _
) As Boolean
    Dim aParams()   As Variant: aParams = oParams
 
    'Wenn keine Parameter übergeben werden, das ganze abbrechen.
    If UBound(oParams) = -1 Then Err.Raise IT_ERR_NO_PARAMS, "Iterator.listNext", "no Parametes defined"
 
    list = listArray(aParams)
    'Parameter zurückschreiben
    Dim i As Long:  For i = 0 To UBound(oParams)
        oParams(i) = aParams(i)
    Next i
End Function
 
'/**
' * Setzt den pos auf den Start-1 zurück, so dass bei einem toNext() der erste Datensatz kommt
' */
Public Sub reset()
    pos = -1
    loopDirection = itDirect
End Sub
 
'/**
' * Setzt den pos 1 nach dem Ende
' */
Public Sub toEOF()
    pos = Me.Count
    loopDirection = itDirect
End Sub
 
'/**
' * Extrahiert die Keys in eine Liste. Die Liste kann vom Type Array, Collection oder Dictionary sein
' * @param  Variant     Liste in welche die Keys extrahiert werden soll
' * @param  Variant     Bei einem Dictionary kann ein Default-Value mitgegeben werden. In Dem Fall wird der Key auch als Key in das Dictionary eingetragen
' * @return Boolean     Angabe, ob das extrahieren erfolgreich war
' */
Public Function extractKeysTo(ByRef iList As Variant, Optional ByVal iDicDefaultValue As Variant = "NO_DEFAULT") As Boolean
    Dim i As Long
 
    If Not isEmpty Then
        Select Case getListType(iList)
            Case itArray:
                iList = myKeys
                extractKeysTo = True:   Exit Function
            Case itCollection:
                For i = LBound(myKeys) To UBound(myKeys)
                    iList.add myKeys(i)
                Next i
                extractKeysTo = True:   Exit Function
            Case itDictionary:
                For i = LBound(myKeys) To UBound(myKeys)
                    If iDicDefaultValue = "NO_DEFAULT" Then
                        iList.add , myKeys(i)
                    Else
                        iList.add myKeys(i), iDicDefaultValue
                    End If
                Next i
                extractKeysTo = True:   Exit Function
        End Select
    End If
    extractKeysTo = False
End Function
 
'/**
' * Entfernt ein Eintrag aus der Liste
' * Wenn kein Key oder Index angegeben wird, dann wird der aktuelle Eintrag gelöscht.
' * Wird ein Key oder Index mitgegeben, dann wird der entsprechende Eintrag gelöscht.
' * !Vorsicht:  Arrays sind leider nicht sauber referenziert. Damit hat remove im Gegensatz zu Collection und Dictionary
' *             keinen direkten Einfluss auf die Originalliste. Man kann aber mittels .source auf die angepasste Liste
' *             des Iterators zugreifen
' * @param  Variant         Key, Index der Liste oder nix. Index entspricht dem OriginalIndex. Bei nix wird der aktuelle Eintrag entfernt
' * @param  itLoopDirection Bei einem normalen Loop, wird die absolute Position um eins reduziert, damit auch im Loop über toNext()
' *                         Einträge entfernt werden können. Dieses Verhalten kannhier überschriebenwerden
' * @return Boolean         Flag, ob der Eintrag entfernt wurde oder nicht
' */
Public Function remove( _
        Optional ByRef iKeyOrIndex As Variant = Null, _
        Optional ByVal iKeyType As itKeyType = itDefaultKeyType, _
        Optional ByVal iLoopDirection As itLoopDirection = itDefaultDirection _
) As Boolean
    'Wenn die Liste leer ist, abbrechen
    If isEmpty Then Exit Function
 
    Dim removeKey   As Variant: ref removeKey, IIf(IsNull(iKeyOrIndex), KEY, getKey(iKeyOrIndex))
    Dim removeIndex As Long:    removeIndex = getIndex(removeKey)
    Dim actLoopDirection As itLoopDirection:    actLoopDirection = IIf(iLoopDirection = itDefaultDirection, loopDirection, iLoopDirection)
 
    'Wenn die Position ausserhalb der Daten ist, abbrechen
    If removeIndex < firstIndex And lastIndex < removeIndex Then Exit Function
 
    'Je nach Listentyp den aktuellen Eintrag entfernen
    Select Case listType
        Case itDictionary:      map.remove removeKey            'item entfernen
        Case itCollection:      map.remove removeKey:           'item entfernen
        Case itArray:           deleteFromArray map, removeKey  'item entfernen
        'Für den aktuellen Type ist Remove noch nicht definiert
        Case Else:              Err.Raise IT_ERR_NOT_SUPPORTED_MAP, , "function not supportet for this listtype"
    End Select
 
    'key-Liste nachführen
    If isKey(removeKey) Then
        deleteFromArray myKeys, removeIndex     'Speziefischen Key aus der Liste löschen
    Else
        ReDim Preserve myKeys(LBound(myKeys) To UBound(myKeys) - 1) 'map ist ohne key - ergo die Keyliste ienfach um eines reduzieren
    End If
 
    'Cache nachführen
    Cnt = Count
    recalcForEachCollection
 
    'Positionskorrektur
    If IsNull(iKeyOrIndex) Then
        Select Case actLoopDirection
            Case itToNext:  pos = pos - 1   'Position um eins zurücksetzen, damit beim nächsten toNext() der neue EIntrag auf der aktuellen Position ausgegeben wird
            Case itToPrev:  'Do nothing
            Case Else:      'Do nothing
        End Select
        loopDirection = actLoopDirection
    End If
 
    remove = True
End Function
 
'/**
' * Fügt ein Node der Liste hinzu
' * @param  Variant     Neuer Node
' * @param  Variant     Key oder Index. Der Key wird auch zurückgegeben
' * @return Bollean
' */s
Public Function add( _
        ByRef iItem As Variant, _
        Optional ByRef ioKeyOrIndex As Variant = Null _
) As Boolean
    Dim newKey      As Variant
    Dim newIndex    As Long
 
    If keyType = itKey Then
        'Key übernehmen und prüfen
        If IsNull(ioKeyOrIndex) Then Err.Raise IT_ERR_MISSING_KEY, , "List need a key for this item"
        newKey = ioKeyOrIndex
        newIndex = getIndex(newKey)
        If firstIndex <= newIndex And newIndex <= lastIndex Then Err.Raise IT_ERR_DUPLICATE_KEY, , "Key allready exists"
    Else
        'Index übernehmen und prüfen
        If IsNull(ioKeyOrIndex) Then ioKeyOrIndex = lastIndex + 1   'Bei Null, am Ende anfügen
        newIndex = ioKeyOrIndex
        If newIndex > lastIndex + 1 Then newIndex = lastIndex + 1   'Wenn der neue Index zu hoch ist, am Ende anfügen
        If newIndex < firstIndex Then Err.Raise IT_ERR_KEY_NOT_FOUND, , "Index is less then the lowest exist index"
        newKey = newIndex
    End If
 
    'Item einfügen
    Select Case listType
        Case itDictionary:      map.add newKey, iItem
        Case itCollection:      map.add iItem
                                newIndex = map.Count
                                newKey = newIndex
        Case itArray:           addToArray map, iItem, newIndex
        'Für den aktuellen Type ist add() noch nicht definierts
        Case Else:              Err.Raise IT_ERR_NOT_SUPPORTED_MAP, , "function not supportet for this listtype"
    End Select
 
    'Keys nachführen
    addToArray myKeys, newKey, newIndex
 
    'Cache nachführen
    Cnt = Count
    recalcForEachCollection
 
    add = True
    ioKeyOrIndex = newKey
End Function
 
'-------------------------------------------------------------------------------
'-- Public Aliase
'-------------------------------------------------------------------------------
' Andere Formen der bestehenden Methoden

'/**
' * Analog zu add(). Gibt jedoch den Iterator selber zurück
' * @param  Variant     Neuer Node
' * @param  Variant     Key oder Index. Der Key wird auch zurückgegeben
' * @param  Boolean     Flag ob der Add funktioniert hat
' * @return Iterator
' */
Public Function add1( _
        ByRef iItem As Variant, _
        Optional ByRef ioKeyOrIndex As Variant = Null, _
        Optional ByRef oAdded As Boolean _
) As Iterator
    oAdded = add(iItem, ioKeyOrIndex)
    Set add1 = Me
End Function
 
'/**
' * Analog zu toNext. Gibt aber den Iterator selber zurück
' * Schiebt den Zeiger ebenfalls um eins vor
' * Der Key und EOF werden als Parameter zurückgegeben
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Current
' * @param  Boolean     EOF
' * @return Variant     Current
' */
Public Function toNext1( _
        Optional ByRef oKey As Variant, _
        Optional ByRef oValue As Variant, _
        Optional ByRef oEOF As Boolean _
) As Iterator
    oEOF = toNext(oKey, oValue)
    Set toNext1 = Me
End Function
 
'/**
' * Analog zu toNext. Gibt aber den neuen current zurück
' * Schiebt den Zeiger ebenfalls um eins vor
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Current
' * @return Iterator
' */
Public Function toKey1( _
        ByRef iKey As Variant, _
        Optional ByRef oValue As Variant, _
        Optional ByRef oEOF As Boolean _
) As Iterator
    oEOF = toKey(iKey, oValue)
    Set toKey1 = Me
End Function
 
'/**
' * Analog zu toPosition. Gibt aber den Iterator zurück
' * Geht zu einer spezifischen Position (begnnt bei 0). Der Key und der Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Long        Absolute Position. Zwischen 0 und Count-1
' * @param  Variant     Key oder index des Items
' * @param  Variant     Das Item himself
' * @return Boolean     EOF

' * @return Iterator
' */
Public Function toPosition1( _
        ByVal iAbsolutePosition As Long, _
        Optional ByRef oKey As Variant, _
        Optional ByRef oValue As Variant, _
        Optional ByRef oEOF As Boolean _
) As Iterator
    oEOF = toPosition(iAbsolutePosition, oKey, oValue)
    Set toPosition1 = Me
End Function
 
'/**
' * Geht zum nächsten Datensatz. Der Key und er Datensatz werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Key oder pos des Items
' * @param  Variant     Das Item himself
' * @return Iterator
Public Function toLast1( _
        Optional ByRef oKey As Variant = Null, _
        Optional ByRef oItem As Variant = Null, _
        Optional ByRef oEOF As Boolean _
) As Iterator
    oEOF = toLast(oKey, oItem)
    Set toLast1 = Me
End Function
 
 
 
'/**
' * Analog zu toNext. Gibt aber den neuen current zurück
' * Schiebt den Zeiger ebenfalls um eins vor
' * Der Key und EOF werden als Parameter zurückgegeben
' * @param  Variant     Key oder pos des Items
' * @param  Boolean     EOF
' * @return Variant     Current
' */
Public Function toNextValue(Optional ByRef oKey As Variant, Optional ByRef oEOF As Boolean) As Variant
    oEOF = toNext(oKey, toNextValue)
End Function
 
'/**
' * Analog zu toNext. Gibt aber den neuen key zurück
' * Schiebt den Zeiger ebenfalls um eins vor
' * Der Current und dEOF werden als Parameter zurückgegeben, EOF als Return-Value
' * @param  Variant     Current
' * @param  Boolean     EOF
' * @return Variant     Key
' */
Public Function toNextKey(Optional ByRef oValue As Variant, Optional ByRef oEOF As Boolean) As Variant
    oEOF = toNext(toNextKey, oValue)
End Function
 
 
'/**
' * Analog zu toNext. Gibt aber den neuen current zurück
' * Schiebt den Zeiger ebenfalls um eins vor
' * @return Variant
' */
Public Function toKeyValue(ByRef iKey As Variant) As Variant
    toKey iKey, toKeyValue
End Function
 
'-------------------------------------------------------------------------------
'-- Private Methodes
'-------------------------------------------------------------------------------

Private Sub raiseEndOf(pos As PositionEnum)
#If isAccess Then
    RaiseEvent arriveEndOf(pos)
#End If
End Sub
 
'/**
' * Eintrag aus einem Array entfernen
' */
Private Sub deleteFromArray(ByRef ioArray As Variant, ByVal iIndex As Long)
    Dim idx As Long: For idx = iIndex To UBound(ioArray) - 1
        ioArray(idx) = ioArray(idx + 1)
    Next idx
    ReDim Preserve ioArray(LBound(ioArray) To UBound(ioArray) - 1)
End Sub
 
'/**
' * Wert zu einem Array hinzufügen
' */
Private Sub addToArray(ByRef ioArray As Variant, ByRef iItem As Variant, ByVal iIndex As Long)
    On Error Resume Next
    If UBound(ioArray) >= 0 Then
        ReDim Preserve ioArray(LBound(ioArray) To UBound(ioArray) + 1)
    Else
        ReDim ioArray(0)
    End If
    If Err.Number <> 0 Then
        ReDim ioArray(0)
    End If
    On Error GoTo 0
 
    Dim idx As Long: For idx = iIndex To UBound(ioArray) - 1
        ioArray(idx + 1) = ioArray(idx)
    Next idx
    ref ioArray(iIndex), iItem
 
End Sub
 
'/**
' * Ermittelt die Position eines Keys
' * @param  Variant Key
' * @retrun Long
' */
Private Function posFromKey(ByVal iKey As Variant) As Long
    Dim flag As Boolean
    For posFromKey = 0 To Cnt - 1
        If myKeys(posFromKey) = iKey Then
            flag = True
            Exit For
        End If
    Next posFromKey
    If flag = False Then Err.Raise IT_ERR_KEY_NOT_FOUND, "Iterator.toKey", "Key '" & iKey & "' not found in list"
End Function
 
'/**
' * Gibt eine Referenz auf das Item zurück
' * @param  oItem       Ausgabeparameter: das aktuelle Item
' */
Private Sub getCurrent(Optional ByRef oItem As Variant = Null, Optional ByVal iDaoValue As Boolean = False)
    Dim curr As Variant
On Error GoTo Err_Handler
 
    Select Case listType
        Case itDaoRecordset:
            map.absolutePosition = Me.absolutePosition
            ref curr, map.fields
        Case itDaoFields:
            ref curr, map(Me.absolutePosition)
        Case Else:
            ref curr, map(Me.KEY)
    End Select
 
    ref oItem, curr
 
    'ggf Value anstelle des Current zurückgeben
    If Me.paramDaoValue Or iDaoValue Then
        Select Case listType
            Case itDaoFields, itMatch, itProperties:
                On Error Resume Next
                ref oItem, curr.value        'Value-Property auslesen
                If Err.Number <> 0 Then value = "#ERR (" & Err.Number & ") " & Err.description
        End Select
    End If
 
Exit_Handler:
    Exit Sub
Err_Handler:
    Err.Raise Err.Number, Err.source, Err.description, Err.helpContext, Err.helpContext
    Resume Exit_Handler
    Resume
End Sub
 
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * oNode = iNode
' * @param  Variant     Variable, die den Wert bekommen soll
' * @param  Variant     Ret Wert selber
' */
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then
        'Objekte als referenz übergeben
        Set oNode = iNode
    Else
        'Je nach Datentyp der erwartet wird handeln.
        Select Case TypeName(oNode)
            Case "String":      oNode = CStr(NZ(iNode))
            Case "Integer":     oNode = CInt(NZ(iNode))
            Case "Long":        oNode = CLng(NZ(iNode))
            Case "Double":      oNode = CDbl(NZ(iNode))
            Case "Byte":        oNode = CByte(NZ(iNode))
            Case "Decimal":     oNode = CDec(NZ(iNode))
            Case "Currency":    oNode = CCur(NZ(iNode))
            Case "Date":        oNode = CDate(NZ(iNode))
            Case "Nothing":
            Case Else:          oNode = iNode
        End Select
    End If
End Sub
 
'/**
' * Ermittelt den Type einer Liste
' * @param  Variant     Die Liste
' * @return itListType
' */
Private Function getListType(ByRef iList As Variant) As itListType
    If IsArray(iList) Then
        getListType = itArray
        Dim d As Dictionary
    ElseIf listTypes.exists(TypeName(iList)) Then
         getListType = listTypes(TypeName(iList))
    Else
        getListType = itNoList
    End If
End Function
 
'/**
' * Ggibt die Elemente der aktuellen Unterliste als Array aus.
' * @param  Array<Variant>    Auflistung der Variablen, die abgefüllt werden
' * @return EOF & BOF
' */
Private Function listArray( _
        ByRef oParams() As Variant _
) As Boolean
    Dim uBnd    As Long:            uBnd = UBound(oParams)
 
    listArray = Not Me.EOF And Not Me.BOF
    If Not listArray Then Exit Function             'SubItem ist keine gültige Liste -> Exit
    If uBnd = -1 Then Exit Function                 'Keine Parameter zum abfüllen -> Exit

    Dim it As New Iterator: it.initialize Me.current 'Iterator für die Subliste initializieren
    Do While it.toNext
        If uBnd < it.absolutePosition Then Exit Do  'Wenn die Parameter ausgehen, Do verlasssen
        ref oParams(it.absolutePosition), it.current
    Loop: Set it = Nothing
End Function
 
'/**
' * Gibt je nach Datentyp von oKey und Settings den Key oder den Index zurück
' * Logik:  oKey ist ein Zahl, me.Key nicht -> Index
' *         Der Paramter itIndexInsteadKey wurde gesetzt -> Index
' *         Ansonsten -> Key
' * @param  Referenz auf den Key
' */
Private Sub keyOrIndex(ByRef oKey As Variant)
    If _
            ( _
                IsNumeric(oKey) _
                And Not IsNumeric(Me.KEY) _
            ) Or Me.paramIndexInsteadKey _
    Then
        'Index anstelle des Keys
        oKey = Me.absolutePosition
    Else
        'Key
        ref oKey, Me.KEY
    End If
End Sub
 
'/**
' * Gint die Information zurück, ob der Zeiger ein Key oder ein Index ist
' * true => Key, false => index
' * @param  Varaint     Zeiger auf d
' * @return Boolean
' */
Private Function isKey(ByRef iKey As Variant) As Boolean
    isKey = (keyType And itKey) And Not IsNumeric(iKey)
End Function
 
'/**
' * Setzt oder entfernt ein Parameter im myParams
' * @param  Boolean     Setzen = true, entfernen = false
' * @param  itParams    Parameter der gesetzt werden soll
' */
Private Sub setParam(ByVal iFlag As Boolean, ByVal iParam As itParams)
    If iParam > 0 Then
        If iFlag And Not CBool(myParams And iParam) Then
            'Flag ist auf setzen, Para ist noch nicht gesetzt
            myParams = myParams + iParam
        ElseIf Not iFlag And CBool(myParams And iParam) Then
            'Flag ist False, Parameter ist vorerst noch gesetzt
            myParams = myParams - iParam
        End If
    End If
End Sub
 
'/**
' * erstellt die Key-Liste
Private Sub createKeyList()
    Dim i
    If Not isEmpty Then
        ReDim myKeys(delta To Cnt - 1 + delta)
        Select Case listType
            Case itDictionary:
                myKeys = map.keys
                keyType = itKey
            Case itDaoFields, itProperties, itExcelSheets:
                For i = LBound(myKeys) To UBound(myKeys)
                    myKeys(i) = map(i).Name
                Next i
                keyType = itKey
            Case Else
                For i = LBound(myKeys) To UBound(myKeys)
                    myKeys(i) = i
                Next i
                keyType = itIndex
        End Select
    End If
End Sub
 
'/**
' * Die Collection zum Iterieren neu aufbauen
' * Für "For Each value in it" braucht es leider eine Collection
' * Darum wird hier alles in eine eigene Collection abgefüllt
' */
Private Sub recalcForEachCollection()
    Dim bookmark As Long:   bookmark = Me.absolutePosition
    Set forEachCollection = New Collection
    Me.reset
    Do While Me.toNext
        forEachCollection.add Me.current
    Loop
    Me.toPosition bookmark
End Sub
 
'/**
' * Gibt anhand eines Keys oder Index den key zurück
' * @param  Variant     Key
' * return  Variant
' */
Private Function getKey(ByRef iKeyOrIndex As Variant, Optional ByVal iKeyType As itKeyType) As Variant
    If isKey(NZ(iKeyOrIndex)) Then
        ref getKey, iKeyOrIndex
    Else
        ref getKey, myKeys(NZ(iKeyOrIndex))
    End If
End Function
 
'/**
' * Gibt anhand eines Keys den Index zurück
' * @param  Variant     Key
' * return  Long
' */
Private Function getIndex(ByRef iKey As Variant, Optional ByVal notFoundGetNextIdx As Boolean = True) As Long
    getIndex = IIf(notFoundGetNextIdx, lastIndex + 1, firstIndex - 1)
    Dim i As Long: For i = LBound(myKeys) To UBound(myKeys)
        If myKeys(i) = iKey Then
            getIndex = i
            Exit For
        End If
    Next i
End Function
 
'/**
' * Zerlegt eine Nummer ihn ihre Bytes.
' * @param  Long        Die Nummer, welche 'zerlegt' werden soll
' * @param  baValueType Art des Inhalt des Array.
' * @param  Boolean     Flag, ob alle 0er-Bit ausgefiltert werden sollen
' * @return Array(Variant)
' */
Private Function bitArray( _
        ByVal iNumber, _
        Optional ByVal iValueType As baValueType = baBit, _
        Optional ByVal iFilteredOut As Boolean = False _
) As Variant()
    Dim pos         As Long:    pos = 0     'Index
    Dim k           As Long:    k = 0    'Array-Index
    Dim value       As Variant
    Dim bit         As Boolean
    Dim retArray()  As Variant
    Dim bitPos      As Variant
 
    Do While (2 ^ pos) <= iNumber
        'Der Value ermitteln, der in den Array abgefüllt wird
        bit = CBool(iNumber And 2 ^ pos)
        value = IIf(bit, CLng(2 ^ pos), False)
        bitPos = IIf(bit, pos, False)
 
        'Prüfen, ob nur die geseztzen Bites ausgegeben werden sollen
        If iFilteredOut And bit Then
            ReDim Preserve retArray(k)
            retArray(k) = Choose(iValueType, bitPos, Abs(bit), value)
            k = k + 1
        ElseIf Not iFilteredOut Then
            ReDim Preserve retArray(pos)
            retArray(pos) = Choose(iValueType, bitPos, Abs(bit), value)
        End If
        pos = pos + 1
    Loop
    bitArray = retArray
End Function
 
'/**
' * Prüft ein Wert gegen eine Liste von Werten.
' * Bei Objekten geht es nur auf dieselbe Instanz.
' * @param  Variant     Wert der gesucht wird
' * @paramArray         Werte gegen die geprüft wird
' * @return Boolean     Flag ob der Wert gefunden wird
Private Function inSet(ByRef iSearch As Variant, ParamArray iItems() As Variant) As Boolean
    Dim item As Variant: For Each item In iItems
        'Null Vergleich
        If IsNull(iSearch) Or IsNull(item) Then
            inSet = IsNull(iSearch) = IsNull(item)
        'Objekt-Vergleich
        ElseIf IsObject(iSearch) And IsObject(item) Then
            inSet = (iSearch Is item)
        'Value-Vergleich
        ElseIf Not IsObject(iSearch) And Not IsObject(item) Then
            inSet = (NZ(iSearch) = NZ(item))
        End If
        If inSet Then Exit Function
    Next item
End Function
 
'-------------------------------------------------------------------------------
' -- Public Properties
'-------------------------------------------------------------------------------
'/**
' * Referent auf die Aktuelle Liste
' */
Public Property Get source() As Variant
    ref source, map
End Property
Public Property Let source(ByRef iList As Variant)  'Setzen für Objekte
    Me.initialize iList
End Property
Public Property Set source(ByRef iList As Variant)  'Setzen für Arrays
    Me.initialize iList
End Property
 
'/**
' * Gibt das aktuelle Item zurück
' */
Public Property Get current() As Variant
    getCurrent current
End Property
 
'/**
' * Gibt den Value aus. Bei den meisten Listen entspricht das dem current.
' */
Public Property Get value() As Variant
    getCurrent value, True
End Property
 
'/**
' * Key oder pos des aktuellen Item.
' * Bei Dictionaries ist es der Key, beim Rest der Index
' */
Public Property Get KEY() As Variant
    Select Case listType
        Case itDictionary, itProperties, itDaoFields, itExcelSheets, itExcelWoorkbook:
            If LBound(myKeys) <= Me.index And Me.index <= UBound(myKeys) Then
                KEY = myKeys(Me.index)        'Bei Dictioniraies, Fields, Properties, den KEY/Namen ausgeben
            Else
                KEY = Empty
            End If
        Case Else:
            KEY = Me.index              'Ansonsten den Index
    End Select
End Property
 
'/**
' * Index des aktuellen Item. Auch bei Dictionaries wird der index ausgegeben, nicht der Key
' * Der Index kann je nach listType unterschiedlich beginnen. Bei Arrays beginnt er bei lbound(map), bei Collections mit 1 und beim Rest mit 0
' */
Public Property Get index() As Long
    index = pos + delta
End Property
 
'/**
' * Unabhängig von der Indexierung der Liste (lBound() bei Array, starten mit 1 bei Collection)
' * Die Absolute Position in der Liste, beginnend mit 0
' * Bei einer leeren Liste wird -1 ausgegeben
' */
Public Property Get absolutePosition() As Long
    absolutePosition = pos
End Property
 
'/**
' * End Of File
' */
Public Property Get EOF() As Boolean
    EOF = IIf(isEmpty, True, pos >= Cnt)
End Property
 
'/**
' * Begin Of File
' */
Public Property Get BOF() As Boolean
    BOF = IIf(isEmpty, True, pos < 0)
End Property
 
'/**
' * Gibt die Anzhal Items der Liste zurück
' */
Public Property Get Count() As Long
    If isEmpty Then
        Count = 0
    Else
        Select Case listType
            Case itArray:
                Count = (UBound(map) + 1) - LBound(map)
            Case itDaoRecordset:
                Dim bookmark As Variant:    bookmark = map.bookmark
                map.MoveLast
                Count = map.recordCount
                map.bookmark = bookmark
            Case Else:
                Count = map.Count
        End Select
    End If
End Property
 
'/**
' * Letzter Index. UBOUND() eines Array.
' */
Public Property Get lastIndex() As Long
    lastIndex = Me.Count - 1 + delta
End Property
 
'/**
' * Erster Index. LBOUND() eines Arrays
' */
Public Property Get firstIndex() As Long
    firstIndex = delta
End Property
 
'/**
' * Prüft ob die Liste leer ist
' */
Public Property Get isEmpty() As Boolean
    Select Case listType
        Case itArray:
            On Error Resume Next
            Dim dummy As Long: dummy = LBound(map)
            isEmpty = IIf(Err.Number <> 0, True, UBound(map) < LBound(map))
        Case itDaoRecordset:
            isEmpty = (map.recordCount = 0)
        Case Else:
            isEmpty = (map.Count = 0)
    End Select
End Property
 
''/**
'' * Gibt current als Iterator zurück
'' */
'Public Property Get subIterator() As Iterator
'    If subItCache(Me.absolutePosition) Is Nothing Then
'        Set subItCache(Me.absolutePosition) = New Iterator
'        subItCache(Me.absolutePosition).initialize Me.current
'    End If
'    Set subIterator = subItCache(Me.absolutePosition)
'End Property

'/**
' * Information, ob der Iterator initialisiert ist
' */
Public Property Get isInitialized() As Boolean
    isInitialized = flagIsInitialized And Not isNothing(map)
End Property
 
'/**
' * Die Parameter als Enum-Set
' * @param  itParam
' */
Public Property Get Params() As itParams
    Params = myParams
End Property
Public Property Let Params(ByVal iParams As itParams)
    If iParams < 0 Then
        If Not isInitialized Then myParams = itDefault
        Dim pp As Variant: pp = bitArray(Abs(iParams), baValue, True)
        Dim i As Integer: For i = 0 To UBound(pp)
            If itDefault And pp(i) Then myParams = myParams - pp(i)
        Next i
    Else
        myParams = iParams
    End If
End Property
 
'/**
' * Die Keys als Array
' */
Public Property Get keys() As Variant()
    keys = myKeys
End Property
 
'/**
' * Die Collection der Items, die fürs Iterieren verwendet wird
' * @return Collection
'*/
Public Property Get forEachCol() As Collection
    ref forEachCol, forEachCollection
End Property
 
' --  DIE SETTINGS ALS EINZELPROPERTIES ---
' Die Settings können über diese Properties nach dem Initialisieren einzeln gesetzt werden

'itNothingAsEmptyList = 2 ^ 0
'Leerer String, Nothing, Empty, Null wird als leere Liste akzeptiert und wirft kein Fehler
'Da dieses Attribut beim initialize() verwendet wird, macht es keinen Sinn dieses Flag später zu ändern
Public Property Get paramNothingAsEmptyList() As Boolean
    paramNothingAsEmptyList = (myParams And itNothingAsEmptyList)
End Property
 
'itListNextNoParamsAsToNext = 2 ^ 1
'Wenn bei listNext keine Parameter angeben werden, einfach eins vorrücken.
Public Property Get paramListNextNoParamsAsToNext() As Boolean
    paramListNextNoParamsAsToNext = (myParams And itListNextNoParamsAsToNext)
End Property
Public Property Let paramListNextNoParamsAsToNext(ByVal iFlag As Boolean)
    setParam iFlag, itListNextNoParamsAsToNext
End Property
 
'itErrorAtEmptyList = 2 ^ 2
'Fehler generieren, wenn die iListe leer ist
Public Property Get paramErrorAtEmptyList() As Boolean
    paramErrorAtEmptyList = (myParams And itErrorAtEmptyList)
End Property
Public Property Let paramErrorAtEmptyList(ByVal iFlag As Boolean)
    setParam iFlag, itErrorAtEmptyList
End Property
 
'itDaoValue = 2 ^ 3
'Field-Value anstelle von Field ausgeben
Public Property Get paramDaoValue() As Boolean
    paramDaoValue = (myParams And itDaoValue)
End Property
Public Property Let paramDaoValue(ByVal iFlag As Boolean)
    setParam iFlag, itDaoValue
End Property
 
'itIndexInsteadKey = 2 ^ 4
'Gibt bei den toX() Funktionen den Index anstelle des Keys zurück
Public Property Get paramIndexInsteadKey() As Boolean
    paramIndexInsteadKey = CBool(myParams And itIndexInsteadKey)
End Property
Public Property Let paramIndexInsteadKey(ByVal iFlag As Boolean)
    setParam iFlag, itIndexInsteadKey
End Property
 
'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
Private Property Get listTypes() As Object
    Static lt As Object
    If lt Is Nothing Then
        Set lt = CreateObject("scripting.Dictionary")
        lt.add "Dictionary", itDictionary
        lt.add "Collection", itCollection
        lt.add "IMatchCollection2", itMatchCollection
        lt.add "IMatch2", itMatch
        lt.add "QueryDef", itQueryDef
        lt.add "TableDef", itTableDef
        lt.add "Recordset2", itDaoRecordset
        lt.add "Fields", itDaoFields
        lt.add "Field2", itDaoField
        lt.add "Properties", itProperties
        lt.add "Sheets", itExcelSheets
        lt.add "Workbook", itExcelWoorkbook
        lt.add "Folder", itFSOFolder
        lt.add "Folders", itFSOFolders
        lt.add "String", itSqlString
        lt.add "OTHER", itNoList
    End If
    Set listTypes = lt
End Property
 
'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------

'/**
' * Version 1.0.1
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/isnothing
' * Prüft, ob eine Variable Null, Empty, Nothing, Leerstring, leerer Array etc ist
' *
' *     boolean = isNothing(object)
' *     boolean = isNothing(vaule)
' *
' * @param  Variant     Variable die geprüft werden soll
' * @return Boolean
' */
Public Function isNothing(ByRef iValue As Variant) As Boolean
    isNothing = True
    Select Case TypeName(iValue)
        Case "Nothing", "Empty", "Null":    Exit Function
        Case "Collection", "Dictionary":    If iValue.Count = 0 Then Exit Function
        Case "String":                      If Len(Trim(iValue)) = 0 Then Exit Function
        Case "Iterator":                    If Not iValue.isInitialized Then Exit Function
        '//TODO: weitere Spezialfälle
        Case Else:
            If IsArray(iValue) Then
                On Error Resume Next
                Dim dummy As Variant: dummy = iValue(LBound(iValue))
                If Err.Number <> 0 Then Exit Function
            End If
    End Select
    isNothing = False
End Function
 
'/**
' * @param  Number
' * @param  incType     Type der Encrementation. Default ist i++
' * @retrun Number
'*/
Private Function inc(ByRef i As Variant, Optional ByVal iIncType As incType = itPreIncrement) As Variant
    Select Case iIncType
        Case itPreIncrement:    i = i + 1:  inc = i     '++i
        Case itPostIncrement:   inc = i:    i = i + 1   'i++
        Case itPreDecrement:    i = i - 1:  inc = i     '--i
        Case itPostDecrement:   inc = i:    i = i - 1   'i--
    End Select
End Function
 

Discussion

Enter your comment. Wiki syntax is allowed:
If you can't read the letters on the image, download this .wav file to get them read to you.
 
vba/classes/iterator/index.txt · Last modified: 11.01.2016 12:04:29 by yaslaw