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.12.3
'Name : Iterator
'Author : Stefan Erb (ERS)
'History : 28.02.2014 - ERS - Creation
' ...
' 10.11.2017 - ERS - Kleine Korrekturen
' 21.11.2017 - ERS - Neue Methoden offset() und offset1()
' 18.12.2017 - ERS - Indexzugriff über Key ermöglicht
' 16.07.2018 - ERS - isEmpty() für Arrax neu mit isMissing gelöst
' 01.03.2019 - ERS - Fehler beim add() ausgemerzt
' 04.09.2019 - ERS - Array() durch emptyArrayVariant() ersetzt
'-------------------------------------------------------------------------------
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
itIndex0List 'Einfache Liste, die bei 0 beginnt
itIndex1List 'Einfache Liste, die bei 1 beginnt
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
'/**
' * Paramter um das Verhalten von CStrF zu steuern
' */
Private Enum itToStringParams
itNon = 0 'Kein Parameter aktiv
itListAsJson = 2 ^ 0 'Falls die Library lib_json installiert ist, die Listen (Array, Dictionary etc) als Json-String zurückgeben. Ansonsten als Werteliste mit Komma getrennt
itRegExpOnlyPattern = 2 ^ 1 'Bei einem Regexp nur den Pattern zurückgeben
itNullAsEmpty = 2 ^ 2 'Null und Nothing als Empty zurückgeben
itNotCastableToError = 2 ^ 3 'Wenn etwas nicht geparst werden kann, dann wird ein Error geworfen. Ansonsten kommt der Text #TypeName zurück (zB. #Form)
itIsSubItem = 2 ^ 9 'Wird nur Intern benutzt
End Enum
'/**
' * Paramter um das Verhalten von CStrF zu steuern
' */
Private Enum csfParams
csfNon = 0 'Kein Parameter aktiv
csfListAsJson = 2 ^ 0 'Falls die Library lib_json installiert ist, die Listen (Array, Dictionary etc) als Json-String zurückgeben. Ansonsten als Werteliste mit Komma getrennt
csfRegExpOnlyPattern = 2 ^ 1 'Bei einem Regexp nur den Pattern zurückgeben
csfNullAsEmpty = 2 ^ 2 'Null und Nothing als Empty zurückgeben
csfNotCastableToError = 2 ^ 3 'Wenn etwas nicht geparst werden kann, dann wird ein Error geworfen. Ansonsten kommt der Text #TypeName zurück (zB. #Form)
csfIsSubItem = 2 ^ 9 'Wird nur Intern benutzt
End Enum
Private Declare Function emptyArrayVariant Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbVariant, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Variant()
Private map As Variant 'Die Liste selber
Private uKeys As Object 'Übersetzung der Keys. Dict(KEY := Key)
Private forEachCollection As Collection 'Für den ForEach braucht es leider eine 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
Private pUid As Variant
'-------------------------------------------------------------------------------
' -- 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 haben 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 andB(params, itKeyIgnoreCase) Then
ref item, map(uKeys(UCase(iIndex))) 'Dictionary mit Keys.
Else
ref item, map(iIndex)
End If
Case Else:
ref item, forEachCollection(iIndex)
'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 andB(iParams, itNotOverwriteMap) <> 0 Then Resume Exit_Handler
Me.params = iParams
'Art der Liste ermitteln
listType = getListType(iList)
'Spezialfälle
If listType = itNoList And paramNothingAsEmptyList Then 'Leer -> Leerer Array
iList = emptyArrayVariant()
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, itIndex1List: 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 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 andB(iParams, 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
'/**
' * Versetzt die Position
' * @param Long Versatz
' * @param Variant Key oder pos des Items
' * @param Variant Das Item himself
' * @return Boolean EOF
' */
Public Function offset( _
ByVal iStep As Long, _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null _
) As Boolean
pos = pos + iStep
offset = Not BOF: If Not offset Then raiseEndOf (adPosBOF): Exit Function
offset = Not EOF: If Not offset Then raiseEndOf (adPosEOF): Exit Function
keyOrIndex oKey
getCurrent oItem
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 oList As Variant, Optional ByVal iDicDefaultValue As Variant = "NO_DEFAULT") As Boolean
Dim i As Long
If Not isEmpty Then
Select Case getListType(oList)
Case itArray:
oList = myKeys
extractKeysTo = True: Exit Function
Case itCollection:
For i = LBound(myKeys) To UBound(myKeys)
oList.add myKeys(i)
Next i
extractKeysTo = True: Exit Function
Case itDictionary:
For i = LBound(myKeys) To UBound(myKeys)
If iDicDefaultValue = "NO_DEFAULT" Then
oList.add , myKeys(i)
Else
oList.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
If Not uKeys Is Nothing Then
If Not uKeys.exists(UCase(newKey)) Then uKeys.add UCase(newKey), newKey
End If
'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 remove(). Gibt jedoch den Iterator selber zurück
' * @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
' * @param Boolean Flag, ob der Eintrag entfernt wurde oder nicht
' * @return Iterator
' */
Public Function remove1( _
Optional ByRef iKeyOrIndex As Variant = Null, _
Optional ByVal iKeyType As itKeyType = itDefaultKeyType, _
Optional ByVal iLoopDirection As itLoopDirection = itDefaultDirection, _
Optional ByRef oRemoved As Boolean _
) As Iterator
oRemoved = remove(iKeyOrIndex, iKeyType, iLoopDirection)
Set remove1 = Me
End Function
'/**
' * Analog zu toFirst. 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 toFirst1( _
Optional ByRef oKey As Variant, _
Optional ByRef oValue As Variant, _
Optional ByRef oEOF As Boolean _
) As Iterator
oEOF = toFirst(oKey, oValue)
Set toFirst1 = 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 letzten 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
Public Function toLeast( _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null _
) As Boolean
toLeast = Me.isEmpty
If toLeast Then Exit Function
Dim it As Iterator: Set it = Me.clone
it.toFirst oKey, oItem
it.reset
Dim v As Variant, k As Variant: Do While it.toNext(k, v)
If NZ(v) < NZ(oItem) Then: oItem = v: oKey = k
Loop
Me.toKey oKey
End Function
Public Function toLeast1( _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null, _
Optional ByRef oEOF As Boolean _
) As Iterator
oEOF = toLeast(oKey, oItem)
Set toLeast1 = Me
If Not oEOF Then Me.toKey oKey
End Function
Public Function toGreatest( _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null _
) As Boolean
toGreatest = Me.isEmpty
If toGreatest Then Exit Function
Dim it As Iterator: Set it = Me.clone
it.toFirst oKey, oItem
it.reset
Dim v As Variant, k As Variant: Do While it.toNext(k, v)
If NZ(v) > NZ(oItem) Then: oItem = v: oKey = k
Loop
Me.toKey oKey
End Function
Public Function toGreatest1( _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null, _
Optional ByRef oEOF As Boolean _
) As Iterator
oEOF = toGreatest(oKey, oItem)
If oEOF Then Exit Function
Set toGreatest1 = Me
If Not oEOF Then Me.toKey oKey
End Function
'/**
' * Versetzt die Position
' * @param Long Versatz
' * @param Variant Key oder pos des Items
' * @param Variant Das Item himself
' * @return Boolean EOF
' */
Public Function offset1( _
ByVal iStep As Long, _
Optional ByRef oKey As Variant, _
Optional ByRef oItem As Variant = Null, _
Optional ByRef oEOF As Boolean _
) As Iterator
oEOF = offset(iStep, oKey, oItem)
Set offset1 = 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
'-------------------------------------------------------------------------------
' -- Interface methodes/properties
'-------------------------------------------------------------------------------
#If IFormattable_exists Then
Private Function IFormattable_cast(iObject As Variant) As IFormattable
End Function
'/**
' * Gibt ein String-Wert des Current zurück
' * @return String
' */
Public Property Get toString(Optional ByVal iFormatString As Variant, Optional ByRef iFormatProvider As FormatProvider) As Variant
If IsObject(iFormatString) Then Set iFormatProvider = iFormatString
Dim toStringParams As itToStringParams: toStringParams = itNullAsEmpty + itNotCastableToError
#If lib_json_exists Then
toStringParams = toStringParams + itListAsJson
#End If
On Error Resume Next
If Not iFormatProvider Is Nothing Then
Dim resArr As Variant
Select Case listType
Case itListType.itArray: resArr = iFormatProvider.format(map)
End Select
toString = cStrF(resArr, toStringParams)
ElseIf Not IsMissing(iFormatString) Then
toString = cStrF(map, toStringParams, iFormatString)
Else
toString = cStrF(map, toStringParams)
End If
End Property
'/**
' * Gibt das Originalobjekt zurück
' * @object
' */
Private Property Get IFormattable_toString(Optional ByVal format As Variant, Optional ByRef iFormatProvider As Object) As String
IFormattable_toString = toString(format, iFormatProvider)
End Property
#Else
'/**
' * Gibt ein String-Wert des Current zurück
' * @return String
' */
Public Property Get toString(Optional ByVal format As String) As String
Dim toStringParams As itToStringParams: toStringParams = itNullAsEmpty + itNotCastableToError
#If lib_json_exists Then
toStringParams = toStringParams + itListAsJson
#End If
On Error Resume Next
toString = cStrF(map, toStringParams)
End Property
#End If
'-------------------------------------------------------------------------------
'-- Private Events
'-------------------------------------------------------------------------------
Private Sub Class_Initialize()
Dim dummy As Variant: dummy = uid(True)
End Sub
'-------------------------------------------------------------------------------
'-- 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 = UBound(ioArray) - 1 To iIndex Step -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
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 = andB(keyType, 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 andB(myParams, iParam) Then
'Flag ist auf setzen, Para ist noch nicht gesetzt
myParams = myParams + iParam
ElseIf Not iFlag And andB(myParams, 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, CStr(Me.key)
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
'/**
' * Erstellt ein Clone des Iterators. Die Position wird nicht mitgeklont
' */
Public Property Get clone() As Iterator
Set clone = Iterator.instance(map, Me.params)
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:
isEmpty = IsMissing(map)
Case itDaoRecordset:
isEmpty = (map.RecordCount = 0)
Case Else:
isEmpty = (map.count = 0)
End Select
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
'Paramter abziehen
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 andB(itDefault, pp(i)) Then myParams = myParams - pp(i)
Next i
Else
'Parameter übernhemen
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 = andB(myParams, itNothingAsEmptyList)
End Property
'itListNextNoParamsAsToNext = 2 ^ 1
'Wenn bei listNext keine Parameter angeben werden, einfach eins vorrücken.
Public Property Get paramListNextNoParamsAsToNext() As Boolean
paramListNextNoParamsAsToNext = andB(myParams, 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 = andB(myParams, 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 = andB(myParams, 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 = andB(myParams, itIndexInsteadKey)
End Property
Public Property Let paramIndexInsteadKey(ByVal iFlag As Boolean)
setParam iFlag, itIndexInsteadKey
End Property
'Eine eindeutige Id der Instanz
Public Property Get uid(Optional iNew As Boolean) As Variant
Static Counter As Variant
If iNew Or pUid = 0 Then
Counter = Counter + 1
pUid = Counter
End If
uid = CDec(CDbl(Now) * 10 ^ 10 & pUid)
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 "AllObjects", itIndex0List
lt.add "References", itIndex1List
lt.add "QueryDefs", itIndex0List
lt.add "TableDefs", itIndex0List
lt.add "VBComponents", itIndex1List
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) And IsMissing(iValue) Then Exit Function
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
'/**
' * Inteligentere Umsetzung des VBA-Befehls CStr
' * Die Funktion erkennt auch Objekte mit dem Interface IFormattable
' * Zudem sind diverse weitere Objekte/Typen abgedeckt
' * @param Variant Value der zu einem String geparst werden soll
' * @param csfParams Paramter um das Verhalten von CStrF zu steuern
' * @retrun String
' */
Private Function cStrF( _
ByRef iValue As Variant, _
Optional ByVal iParams As itToStringParams = itListAsJson + itNullAsEmpty, _
Optional ByVal iFormat As String, _
Optional ByRef FormatProvider As Object, _
Optional ByVal iDelemiter As String = ", " _
) As String
Dim values() As String
Dim i As Long
On Error Resume Next
'Standard CStr
cStrF = CStr(iValue)
If Err.Number = 0 Then Exit Function
'toString Methode
Err.clear
cStrF = iValue.toString
If Err.Number = 0 Then Exit Function
#If IFormattable_exists Then
'IFormattable
Err.clear
Dim tfb As IFormattable: Set tfb = iValue
cStrF = tfb.toString(iFormat, FormatProvider)
If Err.Number = 0 Then Exit Function
#End If
#If lib_json_exists Then
'Array, Dictionary, Collection -> Json
If andB(iParams, itListAsJson) Then
Err.clear
cStrF = obj2json(iValue)
If Err.Number = 0 Then Exit Function
End If
#End If
'Array, Dictionary
Err.clear
If TypeName(iValue) = "Dictionary" Then iValue = iValue.items 'Die Items als Array aus dem Dictionary extrahieren
If IsArray(iValue) Then
'Bei einem Array alle items parsen und zusammenhängen
ReDim values(LBound(iValue) To UBound(iValue))
For i = LBound(iValue) To UBound(iValue)
values(i) = cStrF(iValue(i), iParams + IIf(Not andB(iParams, csfIsSubItem), csfIsSubItem, 0), iDelemiter)
Next i
cStrF = Join(values, iDelemiter)
If andB(iParams, csfIsSubItem) Then cStrF = "(" & cStrF & ")"
If Err.Number = 0 Then Exit Function
End If
'Nach speziellen Typen
Err.clear
On Error GoTo Err_Handler
Select Case TypeName(iValue)
'Null, Nothing
Case "Null", "Nothing": cStrF = IIf(andB(iParams, csfNullAsEmpty), Empty, notCastable(iValue, iParams))
'RegExp -> Gibt den pattern inkl. Paramters zurück
'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern
Case "IRegExp2":
cStrF = iValue.pattern
If Not andB(iParams, csfRegExpOnlyPattern) Then cStrF = "/" & cStrF & "/" & IIf(iValue.IgnoreCase, "i", "") & IIf(iValue.Global, "g", "") & IIf(iValue.Multiline, "m", "")
'MatchCollection
Case "IMatchCollection2":
If iValue.count = 0 Then Exit Function
ReDim values(iValue.count - 1)
For i = 0 To iValue.count - 1
values(i) = iValue(i).value
Next i
cStrF = cStrF(values, iParams, iDelemiter)
'Nur den Typenname ausgeben
Case Else: cStrF = notCastable(iValue, iParams)
End Select
Exit_Handler:
Exit Function
Err_Handler:
cStrF = notCastable(iValue, iParams)
Resume Exit_Handler
End Function
'/**
' * Handel den Fall, dass ein Wert nicht in String geparst werden kann
' * @param Variant Value der zu einem String geparst werden soll
' * @param csfParams Paramter um das Verhalten von CStrF zu steuern
' * @retrun String
' */
Private Function notCastable(ByRef iValue As Variant, ByVal iParams As csfParams) As String
'Falls Fehler gewünscht werden, diese ausgeben
'If andB(iparams, csfNotCastableToError) Then Err.Raise C_CSTRF_PARSE_ERROR, , "cStrF: Type " & TypeName(iValue) & " is not castable"
notCastable = "#" & TypeName(iValue)
End Function
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * Macht einen Bit-Vergleich
' * @param Long
' * @param Long
' * @return Boolean
' */
Public Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
andB = ((iHaystack And iNeedle) = iNeedle)
End Function