VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ListStream" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '------------------------------------------------------------------------------- 'File : ListStream.cls ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/ 'Version : 1.9.0 'Name : ListStream 'Author : Stefan Erb (ERS) 'History : 24.09.2019 - ERS - Creation ' 22.05.2020 - ERS - Anpasungen für Excel, ADODB Recordset. Neu: ntTrim(), nUnique(), first(), last() ' 02.06.2020 - ERS - Neue SOurce: Worksheet & Excel-Range ' 04.06.2020 - ERS - Eifache Iteratorfunktionen hinzugefügt. NewEnum (For Each über die Elemente des Objektes), toNext() ets. ' 17.06.2020 - ERS - Korrektur in x__toDictFromRange() ' 24.06.2020 - ERS - Recordset.Fields hinzugefügt, mapItem, mapFirst, mapLast ' mapEval etc. jetzt auch für Excel. Es können da aber keine VB-Befehle sugeführt werden. Dafür Excel Formeln ohn = und mit , anstelle von ;. Siehe auch Evaluate() von MS ' 02.11.2022 - ERS - Add kShift(), nShift(), kPop(), nPop(), slice(), pad(), countValues(), ' filterInListAssoc(), getRand(), kGetRand(), vGetRand(), search() '------------------------------------------------------------------------------- 'Simuliert einen Stream 'Hier noch wichtige Definitionen: ' --- List --- 'Als Liste kommt folgendes in Frage. In den folgenden Kommentaren ist das mit dem Begriff Liste gemeint ' - eindimensionaler Array ' - Dictionary ' - Collection ' - ListStream ' - Iterator https://wiki.yaslaw.info/doku.php/vba/classes/Iterator/index ' - JSON-String (je nachdem ob lib_json geladen ist) https://wiki.yaslaw.info/doku.php/vba/cast/json ' - DAO.Recordset2 (unter Access) ' - ADODB.Recordset ' - Fields ' - Excel.Range ' - IMatchCollection2, IMatch2, ISubMatches ' Alles weitere wird als Einzeleintrag in ein neues Dictionary geschrieben: ListStream(123) -> [0]=>123 ' --- Patternbeschreibung --- 'Bei Ersetzungen können folgende Platzhalter verwendet werden 'zB "Hallo #{value}!", "'#{val}'", "#{key}: #{value}" ' - Value: #{item}#{value}#{val} ' - Index: #{index}#{id}#{idx}#{pos} ' - Key: #{key} ' Wenn JSF + lib_printf (printf auch in der JSF-Klasse aktiviert) vorhanden ist, dann können diese Patterns auch mit den Formatierungen und Formeln erweitert werden ' Siehe dazu https://wiki.yaslaw.info/doku.php/vba/classes/jsf Option Explicit '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'MS Applikation in der die Klasse eingesetzt wird. Es gibt einige Spezifische Dinge 'Für Word etc noch nicht getestet #Const C_ACCESS = "ACCESS" #Const C_EXCEL = "EXCEL" 'Auswahl #Const ms_product = C_ACCESS 'Die folgenden Module geben dem ganzen mehr möglichkeiten. Sie sind nicht zwingend 'Für toStr() und eval() können mit der JSF Klassen noch Formatierungen und Formeln übergeben werden. Ansonsten nur die Wert. 'https://wiki.yaslaw.info/doku.php/vba/classes/jsf #Const JSF = True 'Falls mein Iterator vorhanden ist, kann dieser Als Input oder als Result verwendet werden 'https://wiki.yaslaw.info/doku.php/vba/classes/Iterator/index #Const iterator = True 'Für das Logging kann log4vba verwendet werden. 'https://wiki.yaslaw.info/doku.php/vba/classes/log4vba #Const Log4vba = True #If Log4vba Then 'Und die Settings dazu Private Const C_ERROR_LOG_SETTINGS = eprOutConsole + eprReturnAssert + eprOutMsgBox #End If 'Wenn strToDate vorhanden ist, dann kann das in mapToDate verwendet wird. 'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate #Const strToDate = True 'Mit DEBUG_MODE True wird bei Fehler der debug.assert aktiviert Private Const DEBUG_MODE = False Private Const C_ERR_HANDLER_DEFAULT = 1 'errMsgBox '------------------------------------------------------------------------------- ' -- Public Members '------------------------------------------------------------------------------- Public Enum enuErrHandler errReturnErrorAsValue = 0 'Fehler als Rückgabewert weitergeben errMsgBox = 1 'Unterbrechen und eine MsgBox anzeigen [_Default] = errMsgBox End Enum 'Art der Liste Public Enum enuListType ltArray ltDictionary ltCollection #If iterator Then ltIterator = 80 #End If #If JSF Then ltJsf = 81 #End If End Enum 'Beim Vergleichen kann entweder nach Schlüssel oder nach Wert verglichen werden Public Enum enuCompaireType ctKey = 2 ^ 0 ctValue = 2 ^ 1 ctBoth = ctKey + ctValue End Enum 'Ist der übergebene Wert ien Index oder ein Key. Sind die Keys numerisch ist diese Info wichtig Public Enum enuIndexOrKey ikKey = ctKey ikIndex = 3 End Enum Public Enum enuWorkWith wwKey = ctKey wwIndex = ikIndex wwValue = ctValue End Enum 'Sortierrichtung Public Enum enuSortOrder soAscending = &HA3 'acCmdSortAscending soDescending = &HA4 'acCmdSortDescending End Enum 'Bei Trim() kann angegeben werden, um was für ein Trim es sich handelt Public Enum enuTrimType ttLTrim = 1 'LTRIM() ttRTrim = 2 'RTRIM() ttTrim = 3 'TRIM() (ttLTrim + ttRTrim) End Enum 'Siehe https://wiki.yaslaw.info/doku.php/vba/cast/ctosqlstr Public Enum enuSqlParams sqlIsNullable = 2 ^ 0 'Das Feld darf Null sein sqlNullToEmpty = 2 ^ 1 'Im Null-Fall Empty verwenden sqlStringDoubleQuotes = 2 ^ 2 'Als Standard werden String in Single Quotes geparst '. Mit diesem Paramter werden " verwendet sqlStringNoMaskQuotes = 2 ^ 3 'Falls der Param nicht gesetzt ist, werden Quotes innerhalb eines String dubliziert (maskiert) sqlStringNoQutes = 2 ^ 4 sqlOnErrorAssert = 2 ^ 5 'Bei einem Fehler den Code unterbrechen sqlOnErrorReturnError = 2 ^ 6 'Bei einem Fehler diesen als Wert ausgeben sqlOnErrorReturnNull = 2 ^ 7 'Bei einem Fehler den Wert als Null behandeln [_Default] = sqlOnErrorReturnError + sqlIsNullable + sqlStringNoMaskQuotes End Enum 'Vergleichskonditionen. SInd in Excel anders als in Access - ergo habeich die Eigenen Public Enum enuCondition coEqual coNotEqual coGreaterThan coGreaterThanOrEqual coLessThan coLessThanOrEqual coBetween coNotBetween End Enum Public Enum enuGetItemSpecialType byMaxKey byMinKey byFirst byLast End Enum Public Enum enuIsNothingParams isnNull = 0 ^ 2 'Null isnEmtpy = 1 ^ 2 'Empty isnNothing = 2 ^ 2 'Objekt is Nothing isnZero = 3 ^ 2 '0 isnNullString = 4 ^ 2 'Leerstring "" isnSpaces = 5 ^ 2 'String mit nur leerzeichen " " isnEmptyList = 6 ^ 2 'Leerer Array, Collection, Dictionary isnDefault = isnNull + isnEmtpy + isnNothing + isnZero + isnNullString + isnSpaces + isnEmptyList End Enum Public Enum lsRxFlagsEnum lsRxNotDefined = -1 lsRxNone = 2 ^ 0 'Value 1 lsRxGlobal = 2 ^ 1 'Value 2 Modifier g Global lsRxIgnoreCase = 2 ^ 2 'Value 4 Modifier i IgnoreCase lsRxMultiline = 2 ^ 3 'Value 8 Modifier m multiLine End Enum '------------------------------------------------------------------------------- ' -- Private Members '------------------------------------------------------------------------------- '/** ' * Functionen um Leere Arrays zu erstellen: emptyArray() ' */ Private Declare Function z__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 Declare Function z__emptyArrayDate Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbDate, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Date() Private Declare Function z__emptyArrayString Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbString, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As String() Private Declare Function z__emptyArrayInteger Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbInteger, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Integer() Private Declare Function z__emptyArrayLong Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbLong, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Long() Private Declare Function z__emptyArrayDouble Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbDouble, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Double() Private Declare Function z__emptyArrayBoolean Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbBoolean, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Boolean() Private Declare Function z__emptyArrayObject Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbObject, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Object() '/** ' * Call by Names mit Array für die Argumente: https:://stackoverflow.com/a/36316527 ' * MemCopy für Keys von Coellections: https://stackoverflow.com/a/50063928 ' */ #If Win64 Then Private Declare PtrSafe Function rtcCallByName Lib "VBE7.DLL" (ByVal Object As Object, ByVal ProcName As LongPtr, ByVal callType As VbCallType, ByRef args() As Any, Optional ByVal LCID As Long) As Variant Private Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr) #Else Private Declare Function rtcCallByName Lib "VBE6.DLL" (ByVal Object As Object, ByVal ProcName As Long, ByVal callType As VbCallType, ByRef args() As Any, Optional ByVal LCID As Long) As Variant Private Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) #End If Private Const C_COMPAIRE_MODE_DEFAULT As Long = vbTextCompare 'Standard Vergleichmethode Private Const C_NOT_DEFINED As Long = -1 'Wert für "NA" Private Const C_NOT_CASTEBLE As Long = -2 Private Const C_NULL As String = "#{NULL}" Private forEachCollection As Collection 'Für den ForEach braucht es leider eine Collection-Class Private pList As Object 'Das Dictionary Private pCompareMode As VbCompareMethod 'Vergleichsmethode Private pWithKeys As Boolean 'Ob mit Keys oder mit Index gearbeitet wird Private pByRef As Boolean 'True: Keine neue Instanz erstellen Private pPos& #If Log4vba Then Private pLogger As Log4vba 'Logger #End If '------------------------------------------------------------------------------- ' -- ERROR HANDLER ' Methoden um einen ListStream zu erstellen/initialiesieren '------------------------------------------------------------------------------- '/** ' * Logger ' * @param Error ' * @param String Name der Methode ' * @param Array<> Ein Arry mit den Aufrufparamtern der Method ' */ Private Function handleError(ByRef iError As Variant, ByVal iSourceName As String, ParamArray iValueArray() As Variant) As Variant Dim valueArray() As Variant: If UBound(iValueArray) > -1 Then valueArray = CVar(iValueArray) #If Log4vba Then Debug.Assert pLogger.error(iError, iSourceName, valueArray) #Else Dim desc$: desc = iError.Description Dim no&: no = iError.Number If DEBUG_MODE Then MsgBox "Error: " & no & vbCrLf & desc Debug.Assert Not DEBUG_MODE Else handleError = desc End If #End If End Function '------------------------------------------------------------------------------- ' -- 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 '/** ' * 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 ' */ Public Sub recalcForEachCollection() Set forEachCollection = toCollection End Sub '------------------------------------------------------------------------------- ' -- Initialize Methodes ' Methoden um einen ListStream zu erstellen/initialiesieren '------------------------------------------------------------------------------- Private Sub Class_Initialize() pCompareMode = C_COMPAIRE_MODE_DEFAULT #If Log4vba Then Set pLogger = Log4vba(DEBUG_MODE) pLogger.setTypeSettings ltError, C_ERROR_LOG_SETTINGS 'Damit bei einem statischen zugriff eine Leere Liste definiert ist Set pList = CreateObject("scripting.Dictionary") #End If End Sub '/** ' * Erstellt eine Instanz ' * @param List Die Liste, über welche Iteriert werden soll ' * @param vbCompareMethod Vergleichsmethode ' * @param Boolean Flag ob das Resultat jeweils als Referenz des Originals gehandhabt wird oder nicht ' * @return ListStream ' */ Public Function instance( _ Optional ByRef iList As Variant = Nothing, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByVal iByReference As Boolean = False _ ) As ListStream Attribute instance.VB_UserMemId = 0 'Attribute instance.VB_UserMemId = 0 Set instance = New ListStream instance.initialize iList, iCompareMode, iByReference End Function '/** ' * Initialisiert den Stream ' * @param List Die Liste, über welche Iteriert werden soll ' * @param vbCompareMethod Vergleichsmethode ' * @param Boolean Flag ob das Resultat jeweils als Referenz des Originals gehandhabt wird oder nicht ' * @return Boolean true: iList ist eine Liste und hat Werte ' */ Public Function initialize( _ Optional ByRef iList As Variant = Nothing, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByVal iByReference As Boolean = False _ ) As Boolean On Error GoTo Err_Handler byReference = iByReference CompareMode = iCompareMode Set pList = x__toDict(iList, CompareMode, pWithKeys) recalcForEachCollection pPos = -1 Exit_Handler: Exit Function Err_Handler: handleError Err, "initialize", iList, iCompareMode, iByReference Resume Exit_Handler Resume End Function '/** ' * Erstellt einen ListStream aus einzelnen Elementen ' * @example ? ListStream.init("a", "b", "c").dump -> {0 => a, 1 => b, 2 => c} ' * @param ParamArray Inhalte ' * @return ListStream ' */ Public Function init(ParamArray iItems() As Variant) As ListStream Dim items As Variant: If UBound(iItems) = -1 Then Set items = Nothing Else items = CVar(iItems) Set init = ListStream(items) End Function '/** ' * Erstellt einen ListStream aus einzelnen Elementen, wobei es abwechslend Key und Value ist. ' * @example ? ListStream.initCombine("a", "b", "c").dump -> {a => b, c => NULL} ' * @param ParamArray Inhalte ' * @return ListStream ' */ Public Function initCombine(ParamArray iItems() As Variant) As ListStream Dim items: items = CVar(iItems) Set initCombine = initCombineA(items) End Function Public Function initCombineA(Optional ByRef iItems As Variant = Null) As ListStream On Error GoTo Err_Handler If Not IsArray(iItems) Then Set initCombineA = ListStream(iItems): Exit Function If UBound(iItems) = -1 Then Set initCombineA = ListStream(Nothing): Exit Function Dim dict: Set dict = x__createDict Dim i: For i = 0 To UBound(iItems) Step 2 Dim v: v = Null If i + 1 <= UBound(iItems) Then v = iItems(i + 1) dict.add iItems(i), v Next i Set initCombineA = ListStream(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "initCombineA", iItems Resume Exit_Handler Resume End Function '/** ' * @param Excel.Worksheet / Excel.range ' * @param Boolean Die Erste Zeile beinhaltet ein Header ' * @param Long/String Name der Spalte innerhalb des Ranges, der als Key verwendet werden soll. -1 bedeutet, dass die Zeilennummer als Key verwendet wird ' * @param VbCompareMethod ' * @return ListStream ' */qqqqqqqqqqqqqqqqqqqqqqqqqqqqe Public Function initRange(ByRef iRange As Variant, Optional ByVal iWithHeader As Boolean = True, Optional ByVal iKeyCol = -1, Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) Set initRange = instance(x__toDictFromRange(iRange, iWithHeader, iKeyCol, iCompareMode), iCompareMode) End Function #If ms_product = C_ACCESS Then '/** ' * Erstellt ein ListTsream anhand eines SQL-Statements/View Name/Table Name. Es wird ein currentDb.OpenRecordset() asugeführt ' * @param String Sql/Tablename/Queryname ' * @param vbCompareMethod Vergleichsmethode ' * @param Boolean Flag ob das Resultat jeweils als Referenz des Originals gehandhabt wird oder nicht ' * @return ListStream ' */ Public Function initRs( _ ByVal iSql$, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByVal iByReference As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Set initRs = ListStream(CurrentDb.openRecordset(iSql), iCompareMode, iByReference) Exit_Handler: Exit Function Err_Handler: handleError Err, "initRs", iSql Resume Exit_Handler Resume End Function #End If '/** ' * Erstellt einen ListStream mit Elementen im Bereich von low bis high . Wenn low > high, wird die Sequenz von high nach low sein. ' * @example ? ListStream.range(4,10,2).dump -> {0 => 4, 1 => 6, 2 => 8, 3 => 10} ' * @param Variant Unterster Wert ' * @param Variant Oberster Wert ' * @param Long Schrittgrösse ' * @return ListStream ' */ Public Function range( _ ByVal iLow As Variant, ByRef iHigh As Variant, _ Optional iStep As Long = 1, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i& If IsNumeric(iLow) And IsNumeric(iHigh) Then For i = iLow To iHigh Step Abs(iStep) * IIf(iLow < iHigh, 1, -1) dict.add (i - iLow) / iStep, i Next i Else Dim l&, h&: l = xlsColNumber(iLow): h = xlsColNumber(iHigh) For i = l To h Step Abs(iStep) * IIf(l < h, 1, -1) dict.add i - l, xlsColLetter(i) Next i End If Set range = x__newLS(dict, iCompareMode) Exit_Handler: Exit Function Err_Handler: handleError Err, "range", iLow, iStep, iCompareMode Resume Exit_Handler Resume End Function '/** ' * Erstellt einen ListStream mit num Einträgen des Wertes des value Parameters. ' * @example ? ListSTream.fill(, 3, "a").dump -> {0 => a, 1 => a, 2 => a} ' * @param Variant Unterster Index ' * @param Long Länge ' * @param Variant Fixwert ' * @param CompareMode ' * @return ListStream ' */ Public Function fill( _ Optional ByVal iStart As Long = 0, _ Optional ByVal iSize As Long = 1, _ Optional ByRef iValue As Variant = Null, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim i&: For i = iStart To iStart + iSize - 1 dict.add i, iValue Next i Set fill = x__newLS(dict, iCompareMode) Exit_Handler: Exit Function Err_Handler: handleError Err, "fill", iStart, iSize, iValue, iCompareMode Resume Exit_Handler Resume End Function Public Function fillKey( _ ByRef iKeyList As Variant, _ Optional ByRef iValue, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim values As Object: Set values = x__toDict(iKeyList, iCompareMode) Dim keys As Variant: keys = values.keys Dim k As Variant: For Each k In keys dict.add values(k), iValue Next k Set fillKey = x__newLS(dict, iCompareMode) Exit_Handler: Exit Function Err_Handler: handleError Err, "fillKey", iKeyList, iValue, iCompareMode Resume Exit_Handler Resume End Function '/** ' * Erstellt ein Clone des Objektes ' * @param CompareMode ' * @return ListStream ' */ Public Function clone(Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) As ListStream Set clone = x__newLS(x__cloneDict(iCompareMode), iCompareMode).x__setInternalProperties(pWithKeys) End Function '/** ' * Erstellt eine ListView aus 2 Listen. Eine für die Keys, die Andere für die Values. Ungleiche Anzahl Einträge werden aufgefüllt (siehe Beispiele 2 & 3) ' * @example ? ListSTream.combine(array("a","b"),array(123,456)).dump -> {a => 123, b => 456} ' * @example ? ListStream.combine("[a,b]","[1,2,3]").dump -> {a => 1, b => 2, 2 => 3} ' * @example ? ListStream.combine("[a,b,c]","[11,22]").dump -> {a => 11, b => 22, c => NULL} ' * @param List Liste der Keys ' * @param List Liste der Values ' * @return ListStream ' */ Public Function combine( _ ByRef iKeyList As Variant, _ ByRef iValueList As Variant, _ Optional ByVal iCompareMode As VbCompareMethod = C_COMPAIRE_MODE_DEFAULT _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim keys: keys = x__toDict(iKeyList, iCompareMode).items Dim values: values = x__toDict(iValueList, iCompareMode).items Dim i&: For i = 0 To greatestA(Array(UBound(keys), UBound(values))) Dim key: key = IIf(i > UBound(keys), i, keys(i)) If Not dict.exists(key) Then dict.add key, IIf(i > UBound(values), Null, values(i)) End If Next i Set combine = ListStream(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "combine", iKeyList, iValueList, iCompareMode Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' -- Iterator Methodes/Properties ' Methoden um den LIstStream als verinfachter Iterator anzuwenden '------------------------------------------------------------------------------- '/** ' * Entfernt den Aktuellen Eintrag oder den Eintrg an einer bestimmten Position ' * @param Variant Index oder Key ' * @param enuIndexOrKey ' * @param Variant Out: Der entfertne Value ' * @return ListStream ' */ Public Function remove( _ Optional ByRef iIndex As Variant = 0, _ Optional ByVal iIndexOrKey As enuIndexOrKey = ikIndex, _ Optional ByRef oValue As Variant = Null, _ Optional ByRef oKey As Variant = Null _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__cloneDict() oValue = Null oKey = Null If pList.count = 0 Then GoTo Exit_Handler If Not IsNumeric(iIndex) Then iIndexOrKey = ikKey Dim keys: keys = dict.keys Dim k If iIndexOrKey = ikIndex Then If iIndex < 0 Or iIndex > dict.count - 1 Then GoTo Exit_Handler k = keys(iIndex) Else k = IIf(IsNull(iIndex), keys(dict.count - 1), iIndex) End If If dict.exists(k) Then ref oValue, dict(k) ref oKey, k dict.remove k End If Exit_Handler: Set remove = x__newLS(dict) Exit Function Err_Handler:: handleError Err, "remove", iIndex, iIndexOrKey Resume Exit_Handler Resume End Function Public Function kRemove(Optional ByRef iIndex As Variant = Null, Optional ByRef oValue As Variant = Null) As ListStream Set kRemove = remove(iIndex, ikKey, oValue) End Function '/** ' * Gibt den Ersten Eintrag zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfertne Value ' * @return ListStream ' */ Public Function shift(Optional ByRef oValue As Variant = Null) As ListStream Set shift = remove(0, ikIndex, oValue).resetIndex End Function '/** ' * Gibt den Ersten Key zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfertne Key ' * @return ListStream ' */ Public Function kShift(Optional ByRef oKey As Variant = Null) As ListStream Set kShift = remove(0, ikIndex, , oKey) End Function '/** ' * Gibt den Ersten Key und Value zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfernte Key ' * @param Variant Out: Der entfernte Value ' * @return ListStream ' */ Public Function nShift(Optional ByRef oKey As Variant = Null, Optional ByRef oValue As Variant = Null) As ListStream Set nShift = remove(0, ikIndex, oValue, oKey) End Function '/** ' * Gibt den Letzten Eintrag zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfertne Value ' * @return ListStream ' */ Public Function pop(Optional ByRef oValue As Variant = Null) As ListStream Set pop = remove(pList.count - 1, ikIndex, oValue) End Function '/** ' * Gibt den Letzten Key zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfertne Key ' * @return ListStream ' */ Public Function kPop(Optional ByRef oKey As Variant = Null) As ListStream Set kPop = remove(pList.count - 1, ikIndex, , oKey) End Function '/** ' * Gibt den Letzten Key und Value zurück und reduziert die Liste um diesen ' * @param Variant Out: Der entfernte Key ' * @param Variant Out: Der entfernte Value ' * @return ListStream ' */ Public Function nPop(Optional ByRef oKey As Variant = Null, Optional ByRef oValue As Variant = Null) As ListStream Set nPop = remove(pList.count - 1, ikIndex, oValue, oKey) End Function '/** ' * fügt einen Value am Ende hinzu. SIehe auch add() ' * @param Variant Key/Value ' * @param Variant Value ' * @param Long Out: Index des neuen Eintrages ' * @param ListStream ' */ Public Function push( _ Optional ByRef iKey As Variant = Null, _ Optional ByRef iValue As Variant, _ Optional ByRef oIndex& _ ) As ListStream Set push = add(iKey, iValue) oIndex = pList.count - 1 End Function '/** ' * fügt einen Value am Annfang hinzu ' * @param Variant Key/Value ' * @param Variant Value ' * @param Long Out: Index des neuen Eintrages ' * @param ListStream ' */ Public Function unShift( _ Optional ByRef iKey As Variant = Null, _ Optional ByRef iValue As Variant, _ Optional ByRef oIndex& _ ) As ListStream Set unShift = addAtPos(0, iKey, iValue) oIndex = 0 End Function '/** ' * fügt einen Value an einer bestimmten Position hinzu ' * @param Variant Index ' * @param Variant Key/Value ' * @param Variant Value ' * @param ListStream ' */ Public Function addAtPos(ByVal iIndex&, _ Optional ByRef iKey As Variant = Null, _ Optional ByRef iValue As Variant _ ) As ListStream On Error GoTo Err_Handler If iIndex < 0 Then iIndex = 0 If iIndex > pList.count - 1 Then iIndex = count Dim all As ListStream: Set all = add(iKey, iValue) Dim sortIdx&(): ReDim sortIdx(0 To count) Dim i&: For i = 0 To pList.count - 1 sortIdx(i + Abs(i >= iIndex)) = i Next i sortIdx(iIndex) = pList.count Set addAtPos = all.sortByList(sortIdx, ikIndex, True) Exit_Handler: 'Set add = x__newLS(dict) Exit Function Err_Handler:: handleError Err, "addAtPos", iKey, iValue Resume Exit_Handler Resume End Function '/** ' * fügt einen Value am Ende hinzu ' * @param Variant Key/Value ' * @param Variant Value ' * @param ListStream ' */ Public Function add( _ Optional ByRef iKey As Variant = Null, _ Optional ByRef iValue As Variant _ ) As ListStream On Error GoTo Err_Handler If IsMissing(iValue) Then iValue = iKey iKey = Null End If Dim dict As Object: Set dict = x__cloneDict() If pWithKeys And Not IsNull(iKey) Then If dict.exists(iKey) Then GoTo Exit_Handler dict.add iKey, iValue Else dict.add dict.count, iValue End If Exit_Handler: Set add = x__newLS(dict) Exit Function Err_Handler:: handleError Err, "add", iKey, iValue Resume Exit_Handler Resume End Function '/** ' * Füllt die Liste mit einem Festwert auf ' * @example ? listStream("{a:1,b:2}").pad(4,"x").dump -> {a => 1, b => 2, 0 => x, 1 => x} ' * @example ? listStream("{a:1,b:2}").pad(-4,"x").dump -> {0 => x, 1 => x, a => 1, b => 2} ' * @param Long Länge Die Grösse des Array. Positiv: die Werte werdem am Ende hinzugefügt, ' * Negativ: die Wert werden am Anfang hinzugefügt ' * Kleiner als die Listengrösse: Befehl wird ignoriert ' * @param Variant Wert mit dem gefüllt wird Public Function pad(ByVal iSize As Long, Optional ByRef iValue As Variant = Null) As ListStream If Abs(iSize) = 0 Or Abs(iSize) > count Then ref pad, Me Dim ls As ListStream: Set ls = Me.clone Dim delta&: delta = Abs(iSize) - count 'Dim dict As Object: Set dict = x__cloneDict() Dim dictDelta: Set dictDelta = x__createDict Dim i&: For i = 1 To delta dictDelta.add dictDelta.count, iValue Next i Select Case Sgn(iSize) Case 1: Set pad = merge(dictDelta) Case -1: Set pad = x__newLS(dictDelta).merge(pList) End Select End Function '/** ' * Extrahiert einen Teil der Liste ' * @param Long Start Index. Beginnt mit 0. Negative Zahl wird von Hinten gezählt. -2 ist ab de, zweitletzten Eintrag ' * @param Long Länge. Mit 0 wird bis zum Schluss ausgegeben. Positive Zahl sit die Länge, Negative Zahl wird vom Ende abgezählt ' * @return ListStream ' */ Public Function slice(Optional iStart As Long = 0, Optional iLength As Long = 0) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lastId$: lastId = count - 1 Dim startId& startId = Choose(Sgn(iStart) + 2, lastId - Abs(iStart) + 1, 0, iStart) startId = IIf(startId >= 0 And startId <= lastId, startId, 0) Dim endId& endId = Choose(Sgn(iLength) + 2, lastId - Abs(iLength), lastId, startId + iLength - 1) endId = IIf(endId >= 0 And endId <= lastId, endId, lastId) Dim ks As Variant: ks = pList.keys Dim i&: For i = startId To endId dict.add ks(i), pList(ks(i)) Next i Exit_Handler: ref slice, x__newLS(dict) Exit Function Err_Handler: handleError Err, "slice", iStart, iLength Resume Exit_Handler Resume End Function '/** ' * Falls die Liste keine Keys besitzt, ist der Key analog zum Index. Nach diversen änderungen kann man diesesn zurücksetzen ' * @example ' * Index entspricht nicht mehr dem key: ? ListStream(array("a","x","m")).sort().dump -> {0 => a, 2 => m, 1 => x} ' * Nach dem Reset: ? ListStream(array("a","x","m")).sort().resetIndex.dump -> {0 => a, 1 => m, 2 => x} ' * @retrun ListStream ' */ Public Function resetIndex() As ListStream If Not pWithKeys Then Set resetIndex = values Else Set resetIndex = clone End If End Function '/** ' * Ersetzt die alle Keys ' * @param List Liste der Keys ' * @return ListSteam ' */ Public Function replaceKeys(ByRef iKeyList As Variant) As ListStream Set replaceKeys = combine(iKeyList, pList.items, CompareMode) End Function '/** ' * Fügt eine weitere Liste hinzu ' * @param List ListStream, Array, Dictionaray, Iterator, Iterator ' * @param vbCompareMethod ' * @param Boolean Bei gleichem Key/Index den Wert überschreiben ' * @return ListStream ' */ Public Function merge( _ ByRef iList As Variant, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByVal iOverwrite As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim trg As Object: Set trg = x__cloneDict(iCompareMode) Dim src As Object: Set src = x__toDict(iList, iCompareMode) Dim i&: i = pList.count - 1 Dim k: For Each k In src.keys If pWithKeys Then If Not trg.exists(k) Then trg.add k, src(k) ElseIf iOverwrite Then If VBA.IsObject(src(k)) Then Set trg(k) = src(k) Else trg(k) = src(k) End If Else If Not trg.exists(k) Then trg.add inc(i), src(k) ElseIf iOverwrite Then If VBA.IsObject(src(k)) Then Set trg(k) = src(k) Else trg(k) = src(k) End If End If Next Set merge = ListStream(trg, iCompareMode) Exit_Handler: Exit Function Err_Handler:: handleError Err, "merge", iList, iCompareMode Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' -- Public Properties '------------------------------------------------------------------------------- '/** ' * Die Liste besitzt Keys (Dictionary, Collection ' * @return Boolean ' */ Public Property Let withKeys(ByVal iWithKeys As Boolean) pWithKeys = iWithKeys End Property Public Property Get withKeys() As Boolean withKeys = pWithKeys End Property '/** ' * Die Liste besitzt Keys (Dictionary, Collection ' * @return Boolean ' */ Public Property Let byReference(ByVal iByReference As Boolean) pByRef = iByReference End Property Public Property Get byReference() As Boolean byReference = pByRef End Property Public Function setByReference(ByVal iByReference As Boolean) As ListStream If iByReference Then byReference = iByReference Set setByReference = Me Else Set setByReference = clone setByReference.byReference = iByReference End If End Function '/** ' * @return vbCompareMethod ' */ Public Property Get CompareMode() As VbCompareMethod CompareMode = pCompareMode End Property Public Property Let CompareMode(ByVal iCompareMode As VbCompareMethod) If Not iCompareMode = C_NOT_DEFINED Then pCompareMode = iCompareMode End Property '/** ' * Die Liste dahinter ' * @return Dictionary ' */ Public Property Get list() As Object Set list = pList End Property '/** ' * Setze ein Listen-Objekt ' * @param Object Liste -> Siehe definition im Klassenheader ' */ Public Property Set list(ByRef iList As Object) Set pList = x__toDict(iList) End Property '/** ' * JSON ' */ Public Property Get json() As String json = toJSON() End Property Public Property Let json(ByVal iJson As String) Set pList = x__toDictFromString(iJson) End Property '/** ' * Anzahl Einträge ' * @return Long ' */ Public Property Get count() As Long If pList Is Nothing Then count = -1 Else count = pList.count End If End Property '/** ' * Prüft ob ein Key exisitert. Analog zu Dictionary.exists ' * @param Variant ' * @return Boolean ' */ Public Function exists(ByRef iKey) As Boolean exists = pList.exists(iKey) End Function Public Function existValue(ByRef iValue) As Boolean existValue = x__flipDict(pList, , True).exists(iValue) End Function #If JSF Then Public Property Get isJsfEnabled() As Boolean: isJsfEnabled = True: End Property #Else Public Property Get isJsfEnabled() As Boolean: isJsfEnabled = False: End Property #End If #If iterator Then Public Property Get isIteratorEnabled() As Boolean: isIteratorEnabled = True: End Property #Else Public Property Get isIteratorEnabled() As Boolean: isIteratorEnabled = False: End Property #End If '------------------------------------------------------------------------------- ' -- Vergleichs Methodes ' Methoden, die Vergleichen, Zusammenführen, Vergleichen etc. '------------------------------------------------------------------------------- '/** ' * Gibt alle Elemente zurück, die in der 2ten Liste ebenfalls vorhanden sind ' * @param List Zu vergleichende Liste ' * @param enuCompaireType Was verglichen werden soll: Key oder Value ' * @param vbCompareMethod ' * @return ListStream ' */ Public Function intersec( _ ByRef iList As Variant, _ Optional ByVal iCompaireType As enuCompaireType = ctValue, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim lst As Variant: ref lst, iList Select Case iCompaireType Case ctKey: Set lst = x__flipDict(x__toDict(iList, iCompareMode)) Set intersec = filterInList(lst, ctKey, False, iCompareMode) Case ctValue: Set intersec = filterInList(lst, ctValue, False, iCompareMode) Case ctBoth Set intersec = filterInList(lst, ctValue, False, iCompareMode) Set intersec = intersec.intersec(iList, ctKey, iCompareMode) End Select Exit_Handler: Exit Function Err_Handler:: handleError Err, "intersec", iList, iCompaireType, iCompareMode Resume Exit_Handler Resume End Function Public Function kIntersec( _ ByRef iList As Variant, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream Set kIntersec = intersec(iList, ctKey, iCompareMode) End Function '/** ' * Gibt alle Elemente zurück, die in der 2ten Liste nicht vorhanden sind ' * @param List Zu vergleichende Liste ' * @param enuCompaireType Was verglichen werden soll: Key oder Value ' * @param vbCompareMethod ' * @return ListStream ' */ Public Function diff( _ ByRef iList As Variant, _ Optional ByVal iCompaireType As enuCompaireType = ctValue, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim lst As Variant: ref lst, iList Select Case iCompaireType Case ctKey: Set lst = x__flipDict(x__toDict(iList, iCompareMode)) Set diff = filterInList(lst, ctKey, True, iCompareMode) Case ctValue: Set diff = filterInList(lst, ctValue, True, iCompareMode) Case ctBoth Set diff = filterInList(lst, ctValue, True, iCompareMode) Set lst = x__flipDict(x__toDict(iList, iCompareMode)) Set diff = diff.merge(filterInList(lst, ctKey, True, iCompareMode)) End Select Exit_Handler: Exit Function Err_Handler:: handleError Err, "diff", iCompaireType, iCompareMode Resume Exit_Handler Resume End Function Public Function kDiff( _ ByRef iList As Variant, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream Set kDiff = diff(iList, ctKey, iCompareMode) End Function Public Function compaire( _ ByRef iList As Variant, _ Optional ByVal iCompaireType As enuCompaireType = ctBoth, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As Boolean compaire = diff(iList, iCompaireType, iCompareMode).count = 0 End Function '------------------------------------------------------------------------------- ' -- Sortierungs Methodes ' Methoden, die Vergleichen, Zusammenführen, Vergleichen etc. '------------------------------------------------------------------------------- '/** ' * Mischt die Einträge ' * @param Boolean Setzt den Index zurück (siehe auch resetIndex) ' * @return ListStream ' */ Public Function shuffle(Optional iResetIndex As Boolean = False) As ListStream On Error GoTo Err_Handler Dim a(): ReDim a(pList.count - 1) Dim i&: For i = 0 To pList.count - 1 a(i) = i Next i ShuffleArrayInPlace a Set shuffle = sortByList(a, ikIndex, iResetIndex) Exit_Handler: Exit Function Err_Handler:: handleError Err, "shuffle", iResetIndex Resume Exit_Handler Resume End Function '/** ' * Sortiert den Stream ' * @param enuSortOrder ' * @param enuCompiareType Value oder Key ' * @param Boolean Setzt den Index zurück (siehe auch resetIndex) ' * @return ListStream '*/ Public Function sort( _ Optional iSortOrder As enuSortOrder = soAscending, _ Optional ByVal iCompaireType As enuCompaireType = ctValue, _ Optional iResetIndex As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim aItems() As Variant: aItems = values.toArray Dim aKeys() As Variant: aKeys = keys.toArray Dim i&, k If andB(iCompaireType, ctKey) Then multiQuickSort aKeys, aItems Else multiQuickSort aItems, aKeys End If Dim sortD: Set sortD = x__createDict(iCompaireType) If iSortOrder = soDescending Then For i = UBound(aKeys) To 0 Step -1 k = IIf(Not pWithKeys And iResetIndex, UBound(aKeys) - i, aKeys(i)) sortD.add k, aItems(i) Next i Else For i = 0 To UBound(aKeys) k = IIf(Not pWithKeys And iResetIndex, i, aKeys(i)) sortD.add k, aItems(i) Next i End If Set sort = x__newLS(sortD) Exit_Handler: Exit Function Err_Handler:: handleError Err, "sort", iSortOrder, iCompaireType, iResetIndex Resume Exit_Handler Resume End Function Public Function kSort(Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream Set kSort = sort(iSortOrder, ctKey, iResetIndex) End Function '/** ' * Sortiert den Stream nach einem Wert in einer Unterliste ' * Wie sortByObjProp, aber auf eine lIste von Listen und nicht von Objekten ' * @example ? ListStream("[{sort:5,val:A},{sort:0,val:B},{sort:1,val:C}]").nSort("sort").json -> {1:{'sort':0,'val':'B'},2:{'sort':1,'val':'C'},0:{'sort':5,'val':'A'}} ' * ? ListStream("[{sort:5,val:A},{sort:0,val:B},{sort:1,val:C}]").nSort("sort", soDescending, True).json -> {0:{'sort':5,'val':'A'},1:{'sort':1,'val':'C'},2:{'sort':0,'val':'B'}} ' * @param enuSortOrder ' * @param enuCompiareType Value oder Key ' * @param Boolean Setzt den Index zurück (siehe auch resetIndex) ' * @return ListStream '*/ Public Function nSort(ByVal iIndex, Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream On Error GoTo Err_Handler Set nSort = sortByList(ListStream(pList).mapListNode(iIndex).sort(iSortOrder, ctValue, False).keys) If iResetIndex Then Set nSort = nSort.values Exit_Handler: Exit Function Err_Handler: handleError Err, "nSort", iIndex, iSortOrder, iResetIndex Resume Exit_Handler Resume End Function '/** ' * Sortiert anhand eines ObjektPropery ' * @example ? ListStream(array(DateTime(), datetime(now-12))).sortObjProp("dateValue",VbGet,soAscending).mapObiProp("dateValue", VbGet).dump -> {1 => 29.09.2019, 0 => 10.11.2019} ' * @param String Name der Methode/Getter ' * @param vbCallType Art der Proc ' * @param enuSortOrder ' * @param ParamArray Argumente, Platzhalter(kein String-Parsing, nur ein String mit dem Platzhalter, damit da der Wert eingefügt wird) ' * @return ListStream ' */ Public Function sortByObjProp( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ByVal iSortOrder As enuSortOrder, _ ParamArray iArgs() As Variant _ ) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set sortByObjProp = sortByObjPropA(iProcName, iCallType, iSortOrder, args) End Function '/** ' * Analog zu sortByOpjProp ausser das die Argumente als Array übergeben werden ' */ Public Function sortByObjPropA( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ByVal iSortOrder As enuSortOrder, _ ByRef iArgs() As Variant _ ) As ListStream On Error GoTo Err_Handler Dim trgD As Object: Set trgD = x__createDict Dim aKeys() As Variant: aKeys = pList.keys Dim aItems() As Variant: ReDim aItems(0 To pList.count - 1) Dim i&: For i = 0 To pList.count - 1 Dim k As Variant: k = aKeys(i) If IsObject(pList(k)) Then If isArrayValid(iArgs) Then aItems(i) = callByNameA(pList(k), iProcName, iCallType, x__replaceArgs(k, pList(k), i, iArgs)) Else aItems(i) = CallByName(pList(k), iProcName, iCallType) End If End If Next multiQuickSort aItems, aKeys 'Set srtD = z__sortDictionaryByValue(srtD, iSortOrder) For Each k In aKeys trgD.add k, pList(k) Next k Set sortByObjPropA = x__newLS(trgD) Exit_Handler: Exit Function Err_Handler:: handleError Err, "sortByObjPropA", iProcName, iCallType, iSortOrder, iArgs Resume Exit_Handler Resume End Function '/** ' * Sortiert Werte nach einem eval ' * Muss Public sein ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @param enuSortOrder ' * @return ListStream ' */ Public Function x__sortByEval( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional iSortOrder As enuSortOrder = soAscending, _ Optional iResetIndex As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim srtD As Object: Set srtD = x__mapEval(iStringExpr).list Dim aKeys() As Variant: aKeys = srtD.keys Dim aItems() As Variant: aItems = srtD.items multiQuickSort aItems, aKeys Dim trgD As Object: Set trgD = x__createDict Dim k: For Each k In aKeys trgD.add k, pList(k) Next k Set x__sortByEval = x__newLS(trgD) Exit_Handler: If Not pWithKeys And iResetIndex Then Set x__sortByEval = x__sortByEval.values Exit Function Err_Handler:: handleError Err, "sortByEval", iStringExpr, iSortOrder, iResetIndex Resume Exit_Handler Resume End Function '/** ' * Sortiert den Stream nach einem Wert in einer Unterliste ' * Wie sortByObjProp, aber auf eine lIste von Listen und nicht von Objekten ' * @example ? ListStream("[{sort:5,val:A},{sort:0,val:B},{sort:1,val:C}]").nSort("sort").json -> {1:{'sort':0,'val':'B'},2:{'sort':1,'val':'C'},0:{'sort':5,'val':'A'}} ' * ? ListStream("[{sort:5,val:A},{sort:0,val:B},{sort:1,val:C}]").nSort("sort", soDescending, True).json -> {0:{'sort':5,'val':'A'},1:{'sort':1,'val':'C'},2:{'sort':0,'val':'B'}} ' * @param enuSortOrder ' * @param enuCompiareType Value oder Key ' * @param Boolean Setzt den Index zurück (siehe auch resetIndex) ' * @return ListStream '*/ Private Function x__nSortByEval(ByVal iIndex, Optional ByVal iStringExpr As String = "#{item}", Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream On Error GoTo Err_Handler Set x__nSortByEval = sortByList(ListStream(pList).mapListNode(iIndex).x__sortByEval(iStringExpr, iSortOrder, False).keys) If iResetIndex Then Set x__nSortByEval = x__nSortByEval.values Exit_Handler: Exit Function Err_Handler: handleError Err, "x__nSortByEval", iIndex, iStringExpr, iSortOrder, iResetIndex Resume Exit_Handler Resume End Function #If ms_product = C_ACCESS Then '/** ' * Sortiert Werte nach einem eval ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @param enuSortOrder ' * @return ListStream ' */ Public Function sortByEval(Optional ByVal iStringExpr As String = "#{item}", Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream Set sortByEval = x__sortByEval(iStringExpr, iSortOrder, iResetIndex) End Function Public Function nSortByEval(ByVal iIndex, Optional ByVal iStringExpr As String = "#{item}", Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream Set nSortByEval = x__nSortByEval(iIndex, iStringExpr, iSortOrder, iResetIndex) End Function #ElseIf ms_product = C_EXCEL Then '/** ' * Sortiert Werte nach einem eval ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @param enuSortOrder ' * @return ListStream ' */ Public Function sortByEvaluate(Optional ByVal iStringExpr As String = "#{item}", Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream Set sortByEvaluate = x__sortByEval(iStringExpr, iSortOrder, iResetIndex) End Function Public Function nSortByEvaluate(ByVal iIndex, Optional ByVal iStringExpr As String = "#{item}", Optional iSortOrder As enuSortOrder = soAscending, Optional iResetIndex As Boolean = False) As ListStream Set nSortByEvaluate = x__nSortByEval(iIndex, iStringExpr, iSortOrder, iResetIndex) End Function #End If '/** ' * Sortiert die Liste anhand einer Liste mit Keys oder Index ' * @example ? ListStream("{a:11,b:22,c:33}").sortByList("[2,0,1]").json -> {'c':33,'a':11,'b':22} ' * @param List Liste deren Werte die neue Reihenfolge bestimmt ' * @param enuIndexOrKey ' * @param Boolean Setzt den Index zurück (siehe auch resetIndex) ' * @return ListStream ' */ Public Function sortByList( _ ByRef iIndexList As Variant, _ Optional iIndexOrKey As enuIndexOrKey = ikKey, _ Optional iResetIndex As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim srcD As Object: Set srcD = x__cloneDict() Dim order As Object: Set order = x__toDict(iIndexList) Dim trgD As Object: Set trgD = x__createDict() Dim keys: keys = pList.keys Dim i&: For i = 0 To order.count - 1 Dim k: k = order(i) If IsNumeric(k) And iIndexOrKey = ikIndex Then If k > UBound(keys) Then GoTo EndLoop k = keys(order(i)) End If If srcD.exists(k) Then Dim k2: k2 = IIf(iResetIndex And Not pWithKeys, i, k) trgD.add k2, srcD(k) srcD.remove k End If EndLoop: Next 'Restliche unsortiert hinzufügen For Each k In srcD.keys trgD.add k, srcD(k) Next k Set sortByList = x__newLS(trgD) Exit_Handler: Exit Function Err_Handler:: handleError Err, "sortByList", iIndexList, iIndexOrKey, iResetIndex Resume Exit_Handler Resume End Function '/** ' * Sortiert die Liste anhand einer Liste mit Keys ' * @example ? ListStream("{a:11,b:22,c:33}").ksortByList("[b,a,c]").dump -> {b => 22, a => 11, c => 33} ' * @param List Liste deren Werte die neue Reihenfolge bestimmt ' * @return ListStream ' */ Public Function kSortByList(ByRef iIndexList As Variant) As ListStream Set kSortByList = sortByList(iIndexList, ikKey) End Function '------------------------------------------------------------------------------- ' -- Listenveränderungsmethoden '------------------------------------------------------------------------------- '/** ' * Tauscht Key und Value aus. Resultat-Liste ist ein Dictionary ' * Merfach-Keys werden mit #{id} ergänzt. Bei einem weiteren FLip wird das wieder entfernt ' * @example ? ListStream("{A:a,B:a,C:a}").flip.toJSON -> {'a':'A','a#{1}':'B','a#{2}':'C'} ' * @example ? ListStream("{'a':'A','a#{1}':'B','a#{2}':'C'}").flip.toJSON -> {'A':'a','B':'a','C':'a'} ' * @example ? ListStream("{A:a,B:a,C:a}").flip(True).toJSON -> {'a':'A'} ' * @param Boolean Doppelte Keys unterdrücken und nur den ersten Eintrag übernehmen ' * @return ListStream ' */ Public Function flip(Optional ByVal iUnique As Boolean = False) As ListStream On Error GoTo Err_Handler Set flip = x__newLS(x__flipDict(, False, iUnique)) pWithKeys = True Exit_Handler: Exit Function Err_Handler:: handleError Err, "flip" Resume Exit_Handler Resume End Function '/** ' * Tauscht Key und Value aus. Resultat-Liste ist ein Dictionary ' * Merfach-Keys werden mit #{id} ergänzt. Bei einem weiteren FLip wird das wieder entfernt ' * @example ? ListStream("{A:a,B:a,C:a}").flip.toJSON -> {'a':'A','a#{1}':'B','a#{2}':'C'} ' * @example ? ListStream("{'a':'A','a#{1}':'B','a#{2}':'C'}").flip.toJSON -> {'A':'a','B':'a','C':'a'} ' * @example ? ListStream("{A:a,B:a,C:a}").flip(True).toJSON -> {'a':'A'} ' * @param List ' * @param Boolean Flag, das die Keys in ein String gecastet werden ' * @param Boolean Doppelte Keys unterdrücken und nur den ersten Eintrag übernehmen ' * @return Dictionary ' */ Private Function x__flipDict( _ Optional ByRef iDict As Object = Nothing, _ Optional ByVal iKeyToStr As Boolean = False, _ Optional ByVal iUnique As Boolean = False, _ Optional ByVal iCompareMode As Integer = C_NOT_DEFINED _ ) As Object Static rxV As Object: If rxV Is Nothing Then Set rxV = cRx("/(?:\#\{\d+\})?$/") Dim src As Object: If iDict Is Nothing Then Set src = pList Else Set src = iDict Set x__flipDict = x__createDict(iCompareMode) Dim k: For Each k In src.keys Dim newKey As Variant: newKey = src(k) Dim newValue As Variant: newValue = rxV.replace(NZ(k), "") If iKeyToStr Then newKey = CStr(NZ(newKey, C_NULL)) 'var2CodeStr(newKey, , sqlOnErrorReturnError + sqlIsNullable + sqlStringNoQutes) If x__flipDict.exists(newKey) And Not iUnique Then Dim testKey$: testKey = newKey Dim i&: i = 0 Do While x__flipDict.exists(testKey) testKey = newKey & "#{" & inc(i) & "}" Loop x__flipDict.add testKey, newValue ElseIf Not x__flipDict.exists(newKey) Then x__flipDict.add newKey, newValue End If Next End Function '/** ' * Extrahiert alle Werte zu einer Array-Liste ' * @return ListStream ' */ Public Function values() As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys dict.add inc(i), pList(k) Next Set values = x__newLS(dict).x__setInternalProperties(False) Exit_Handler: Exit Function Err_Handler:: handleError Err, "values" Resume Exit_Handler Resume End Function '/** ' * Entfernt die Values und ersetzt sie durch den Index ' * @example ? ListStream("{a:AA,b:BB}").values2index.dump -> {a => 0, b => 1} ' * @return ListStream ' */ Public Function values2index(Optional ByVal iFirstIndex& = 0) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 + iFirstIndex Dim k: For Each k In pList.keys dict.add k, inc(i) Next Set values2index = x__newLS(dict).x__setInternalProperties(False) Exit_Handler: Exit Function Err_Handler:: handleError Err, "values2index" Resume Exit_Handler Resume End Function '/** ' * Extrahiert alle Keys zu einer Array-Liste ' * @return ListStream ' */ Public Function keys() As ListStream On Error GoTo Err_Handler Set keys = x__newLS(x__keysDict).x__setInternalProperties(False) Exit_Handler: Exit Function Err_Handler:: handleError Err, "keys" Resume Exit_Handler Resume End Function '/** ' * Ersetzt Werte anhand einer List Public Function replaceValues(ByRef iList As Variant) As ListStream Set replaceValues = merge(iList, , True) End Function '/** ' * Erstellt ein Dictionary aus den Keys ' * @param Dictionary ' * @return Dictionary ' */ Private Function x__keysDict(Optional ByRef iDict As Object = Nothing) As Object Dim dict As Object: Set dict = x__createDict Dim src As Object: If iDict Is Nothing Then Set src = pList Else Set src = iDict Dim i&: i = -1 Dim k: For Each k In src.keys dict.add inc(i), k Next Set x__keysDict = dict End Function '/** ' * Wandelt in eine andere Art von Liste ' * @param enuListType Art der Liste ' * @return Variant Dictionary/Array/Collection ' */ Public Function collect(ByVal iListType As enuListType, Optional ByVal iVarType As VbVarType = vbVariant) As Variant On Error GoTo Err_Handler Select Case iListType Case ltArray: collect = toArray(iVarType) Case ltDictionary: Set collect = toDictionary(iVarType) Case ltCollection: Set collect = toCollection(iVarType) #If iterator Then Case ltIterator: Set collect = toIterator(iVarType) #End If #If JSF Then Case ltJsf: Set collect = toJsf(iVarType) #End If '//TODO: Weitere Listen definieren End Select Exit_Handler: Exit Function Err_Handler:: handleError Err, "collect", iListType, iVarType Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' -- Key Methodes ' Methoden, die den Key betreffen '------------------------------------------------------------------------------- '/*** ' * Wandelt alle Keys in Strings um ' * @return ListStream ' */ Public Function mapKeysToStr() As ListStream Set mapKeysToStr = x__newLS(x__keysToStr) End Function Public Function doKeysToStr() As ListStream Set pList = x__keysToStr Set doKeysToStr = Me End Function '/** ' * Alias für die Rückwertskompatibilität ' */ Public Function doKeysToSqlStr(Optional ByVal iVarType As VbVarType = vbVariant) As ListStream Set doKeysToSqlStr = kMapToSqlStr(iVarType) End Function '/** ' * @return Dictionary ' */ Private Function x__keysToStr(Optional ByVal iDict As Object = Nothing, Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) As Object On Error GoTo Err_Handler Dim trgD As Object: Set trgD = x__createDict(iCompareMode) Dim src As Object: If iDict Is Nothing Then Set src = pList Else Set src = iDict Dim k: For Each k In src.keys trgD.add var2CodeStr(k, , sqlOnErrorReturnError + sqlStringNoQutes), pList(k) Next Set x__keysToStr = trgD Exit_Handler: Exit Function Err_Handler:: handleError Err, "x__keysToStr", iCompareMode Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' -- Map Methodes ' Funktionen, die auf jedes ELement der Liste angewednet werden '------------------------------------------------------------------------------- '/** ' * Führt ein Trim auf jedes Element aus. Im gegensatz zum VBA-Trim kann man mit diesem auch Nur Rechts oder Links trimmen. Zudem werden uach \t\n\r getretrimmt ' * @param enuTrimType LTrim/RTrim/Trim (beide Seiten) ' * @return ListStream ' */ Public Function mapTrim(Optional iTrimType As enuTrimType = ttTrim) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, rxTrim(iTrimType).replace(pList(k), "$1") Next k Set mapTrim = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapTrim", iTrimType Resume Exit_Handler Resume End Function '/** ' * Führt einen RegExp Replace auf jedes Element aus ' * @param String Pattern (gemäss https://wiki.yaslaw.info/doku.php/vba/cast/cregexp) ' * @param String Replacement ' * @return ListStream ' */ Public Function mapRegExReplace(ByVal iPattern As String, ByVal iReplace As String) As ListStream On Error GoTo Err_Handler Dim rx As Object: Set rx = cRx(iPattern) Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, rx.replace(pList(k), iReplace) Next k Set mapRegExReplace = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapRegExReplace", iPattern, iReplace Resume Exit_Handler Resume End Function Public Function kMapRegExReplace(ByVal iPattern As String, ByVal iReplace As String) As ListStream Dim ks: ks = keys.mapRegExReplace(iPattern, iReplace).list.items Set kMapRegExReplace = replaceKeys(ks) End Function '/** ' * Formatiert jedes Item. Alle Paramters gemäss VBA.fromat() ' * @param vbVarType ' * @param vbDayOfWeek ' * @param vbFirstWeekOfYear ' * @return ListStream ' */ Public Function mapFormat( _ ByVal iFormat As String, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbMonday, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbFirstFourDays _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, VBA.format(pList(k), iFormat, iFirstDayOfWeek, iFirstWeekOfYear) Next k Set mapFormat = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapFormat", iFormat, iFirstDayOfWeek, iFirstWeekOfYear Resume Exit_Handler Resume End Function Public Function kMapFormat( _ ByVal iFormat As String, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbMonday, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbFirstFourDays _ ) As ListStream Dim ks: ks = keys.mapFormat(iFormat, iFirstDayOfWeek, iFirstWeekOfYear).list.items Set kMapFormat = replaceKeys(ks) End Function ' /** ' * @param Variant Index oder Key der List ' * @param vbVarType Type vorscrheiben ' * @param enuSqlParams Paramter zur Erstellung des SQLS-Wertes ' * @param Variant NULL-Ersatz ' * @return ListStream ' */ Public Function nMapFormat( _ ByVal iIndex, _ ByVal iFormat As String, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbMonday, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbFirstFourDays _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then lst(subKey) = VBA.format(lst(subKey), iFormat, iFirstDayOfWeek, iFirstWeekOfYear) End If dict.add k, lst Next k Set nMapFormat = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "nMapFormat", iIndex, iFormat, iFirstDayOfWeek, iFirstWeekOfYear Resume Exit_Handler Resume End Function '/** ' * Wandelt den Typ über alle Einträge ' * @param vbVarType ' * @return ListStream ' */ Public Function mapCast(ByVal iVarType As VbVarType) As ListStream On Error GoTo Err_Handler If iVarType = vbVariant Then Set mapCast = clone Exit Function End If Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, x__castValue(pList(k), iVarType) Next k Set mapCast = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapCast", iVarType Resume Exit_Handler Resume End Function ' /** ' * @param Variant Index oder Key der List ' * @param vbVarType Type vorscrheiben ' * @param enuSqlParams Paramter zur Erstellung des SQLS-Wertes ' * @param Variant NULL-Ersatz ' * @return ListStream ' */ Public Function nMapCast( _ ByVal iIndex, _ ByVal iVarType As VbVarType _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then lst(subKey) = x__castValue(lst(subKey), iVarType) End If dict.add k, lst Next k Set nMapCast = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "nMapCast", iIndex, iVarType Resume Exit_Handler Resume End Function '/** ' * Castet alle Werte in ein Boolean ' * @return ListStream ' */ Public Function mapToBool() As ListStream: Set mapToBool = mapCast(vbBoolean): End Function '/** ' * Castet alle Werte in ein Long ' * @return ListStream ' */ Public Function mapToLng() As ListStream: Set mapToLng = mapCast(vbLong): End Function '/** ' * Castet alle Werte in ein String ' * @return ListStream ' */ Public Function mapToStr() As ListStream: Set mapToStr = mapCast(vbString): End Function '/** ' * Castet alle Werte in ein Double ' * @return ListStream ' */ Public Function mapToDbl() As ListStream: Set mapToDbl = mapCast(vbDouble): End Function #If strToDate Then '/** ' * Castet alle Werte in ein Datum ' * @example ? ListStream(array("2019-01-01", "2019-11-23")).mapToDate().dump -> {0 => 01.01.2019, 1 => 23.11.2019} ' * @example ? ListStream(array("20190101", "20191123")).mapToDate("YYYYMMDD").dump -> {0 => 01.01.2019, 1 => 23.11.2019} ' * @param String Das Format. Als Standart ist das Systemdatumsformat, siehe Doku zu strToDate ' * @param tdtParams Weitere Parameter, siehe Doku zu strToDate ' * @param VbDayOfWeek Angabe zum ersten Wochentag. Schweiz -> Montag. Standard: Systemeinstellung ' * @param VbFirstWeekOfYear Angabe zum ersten Woche im Jahr. Schweiz -> vbFirstFourDays. Standard: Systemeinstellung ' * @return ListStream ' */ Public Function mapToDate( _ Optional ByVal iFormat As String = vbNullString, _ Optional ByVal iParams As tdtParams = tdtIgnoreCase, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _ ) As ListStream If iFormat = vbNullString Then Set mapToDate = mapCast(vbDate) Else Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, strToDate(pList(k), iFormat, iParams, iFirstDayOfWeek, iFirstWeekOfYear) Next k Set mapToDate = x__newLS(dict) End If End Function #Else '/** ' * Castet alle Werte in ein Datum ' * @example ? ListStream(array("2019-01-01", "2019-11-23")).mapToDate().dump -> {0 => 01.01.2019, 1 => 23.11.2019} ' * @return ListStream ' */ Public Function mapToDate() As ListStream Set mapToDate = mapCast(vbDate) End Function #End If '/** ' * Alle Einträge in Strings wandeln, mittels Pattern mit Platzhaltern. Falls JSF vorhanden ist, können Formatierungen mitgegeben werden ' * @example ? ListSTream(array("Hans","Thomas")).mapParse("[#{key}}: #{item}").dump -> {0} => [0: Hans, 1} => [1: Thomas} ' * @example ? ListSTream(array(now, now+1)).mapParse("#{value $SD}",,true).dump -> {0 => #11/10/2019#, 1 => #12/10/2019#} ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @param vbVarType ' * @param Boolean Mit JSF parsen. Lohnt sich nur, wenn man jsf spezifische Formate anwendet ' * @return ListStream ' */ #If JSF Then Public Function mapParse( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iJsfParse As Boolean = False _ ) As ListStream If iJsfParse Then Set mapParse = mapParseJsf(iStringExpr) If Not (iVarType = vbVariant Or iVarType = vbString) Then Set mapParse = mapParse.mapCast(iVarType) Exit Function End If #Else Public Function mapParse( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iJsfDummy As Boolean = False _ ) As ListStream Dim iJsfParse As Boolean: iJsfParse = False #End If On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys dict.add k, x__nodeToString(iStringExpr, k, pList(k), inc(i), iVarType, False, iJsfParse) Next Set mapParse = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapParse", iStringExpr, iVarType, iJsfParse Resume Exit_Handler Resume End Function #If JSF Then Public Function kMapParse( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iJsfParse As Boolean = False _ ) As ListStream Dim ks As Variant: ks = mapParse(iStringExpr, iVarType, iJsfParse).list.items Set kMapParse = replaceKeys(ks) End Function #Else Public Function kMapParse( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iDummyJsfParse As Boolean = False _ ) As ListStream Dim ks As Variant: ks = mapParse(iStringExpr, iVarType).list.items Set kMapParse = replaceKeys(ks) End Function #End If #If JSF Then Public Function tMapParse( _ Optional ByVal iKeyExpr As String = "#{key}", _ Optional ByVal iValueExpr As String = "#{item}", _ Optional ByVal iJsfParse As Boolean = False _ ) As ListStream Dim ks As ListStream: Set ks = clone.mapParse(iKeyExpr, , iJsfParse) Dim vs As ListStream: Set vs = mapParse(iValueExpr, , iJsfParse) Set tMapParse = combine(ks.list, vs.list) End Function #Else Public Function tMapParse( _ Optional ByVal iKeyExpr As String = "#{key}", _ Optional ByVal iValueExpr As String = "#{item}", _ Optional ByVal iDummyJsfParse As Boolean = False _ ) As ListStream Dim ks As ListStream: Set ks = clone.mapParse(iKeyExpr) Dim vs As ListStream: Set vs = mapParse(iValueExpr) Set tMapParse = combine(ks.list, vs.list) End Function #End If #If JSF Then Public Function mapParseJsf( _ ByVal iStringExpr As String, _ Optional ByVal iParams As jsfParams = jsfParams.[_NA] _ ) As ListStream Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim itemDict As Object: Set itemDict = x__createDict Dim k: For Each k In pList.keys Dim v: v = pList(k) Dim index&: index = inc(i) itemDict.RemoveAll itemDict.add "item", v: itemDict.add "value", v: itemDict.add "val", v itemDict.add "key", k itemDict.add "index", index: itemDict.add "id", index: itemDict.add "pos", index: itemDict.add "idx", index dict.add k, JSF(itemDict).parse(iStringExpr, iParams) Next Set mapParseJsf = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapParse", iStringExpr, iParams Resume Exit_Handler Resume End Function Public Function kMapParseJsf( _ ByVal iStringExpr As String, _ Optional ByVal iParams As jsfParams = jsfParams.[_NA] _ ) As ListStream Dim ks As Variant: ks = mapParseJsf(iStringExpr, iParams).list.items Set kMapParseJsf = replaceKeys(ks) End Function ' /** ' * @param Variant Index oder Key der List ' * @param vbVarType Type vorscrheiben ' * @param enuSqlParams Paramter zur Erstellung des SQLS-Wertes ' * @param Variant NULL-Ersatz ' * @return ListStream ' */ Public Function nMapParseToString( _ ByVal iStringExpr As String, _ Optional ByVal iParams As jsfParams = jsfParams.[_NA] _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys On Error Resume Next Set lst = x__toDict(pList(k), , , , False) If Err.Number <> 0 Then dict.add k, Err.Description Else On Error GoTo Err_Handler dict.add k, JSF(lst).parse(iStringExpr, iParams) End If Next k Set nMapParseToString = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "nMapParseToString", iStringExpr, iParams Resume Exit_Handler Resume End Function #End If '/** ' * Wandelt alle Werte mittels var2CodeStr() in SQL-Strings ' * Funktion, siehe https://wiki.yaslaw.info/doku.php/vba/cast/ctosqlstr ' * @example ? ListSTream(array(now, Null)).mapToSqlStr(vbDate).dump -> {0 => #10/11/2019 14:18:19#, 1 => NULL} ' * @param vbVarType ' * @param enuSqlParams ' * @param Variant ' * @return ListStream ' */ Public Function mapToSqlStr( _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iSqlParams As enuSqlParams = enuSqlParams.[_Default], _ Optional ByVal iNullDefault As Variant = Null _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys dict.add k, var2CodeStr(pList(k), iVarType, iSqlParams, iNullDefault) Next k Set mapToSqlStr = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapToSqlStr", iVarType, iSqlParams, iNullDefault Resume Exit_Handler Resume End Function Public Function kMapToSqlStr( _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iSqlParams As enuSqlParams = enuSqlParams.[_Default] _ ) As ListStream Dim ks: ks = mapToSqlStr(iVarType, iSqlParams).list.items Set kMapToSqlStr = replaceKeys(ks) End Function ' /** ' * @param Variant Index oder Key der List ' * @param vbVarType Type vorscrheiben ' * @param enuSqlParams Paramter zur Erstellung des SQLS-Wertes ' * @param Variant NULL-Ersatz ' * @return ListStream ' */ Public Function nMapToSqlStr( _ ByVal iIndex, _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iSqlParams As enuSqlParams = enuSqlParams.[_Default], _ Optional ByVal iNullDefault As Variant = Null _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then lst(subKey) = var2CodeStr(lst(subKey), iVarType, iSqlParams, iNullDefault) End If dict.add k, lst Next k Set nMapToSqlStr = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "nMapToSqlStr", iIndex, iVarType, iSqlParams, iNullDefault Resume Exit_Handler Resume End Function Public Function mapFirst() As ListStream: Set mapFirst = mapItem(0): End Function Public Function mapLast() As ListStream: Set mapLast = mapItem(count - 1): End Function Public Function mapItem(ByVal iIndex) As ListStream On Error GoTo Err_Handler Dim k If Not x__getKey(iIndex, k) Then Err.Raise "item " & iIndex & " not found in List " & dump Set mapItem = x__newLS(x__toDict(pList(k))) Exit_Handler: Exit Function Err_Handler: handleError Err, "mapItem", iIndex Resume Exit_Handler Resume End Function '/** ' * Die Items sind selber Listen. Dann nimmt die Funktion die Werte an der xten (index oder Key) Postion ' * @param Long ' * @return ListStream ' */ Public Function mapListNode(ByVal iIndex) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k)) If x__getKey(iIndex, subKey, lst) Then dict.add k, lst(subKey) Else dict.add k, "Error: item " & iIndex & " not found in List " & x__newLS(lst).dump End If Next k Set mapListNode = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapListNode", iIndex Resume Exit_Handler Resume End Function Public Function kMapListNode(ByVal iIndex) As ListStream Dim ks: ks = mapListNode(iIndex).list.items Set kMapListNode = replaceKeys(ks) End Function Public Function tMapListNode(ByVal iKeyIndex, ByVal iValueIndex) As ListStream Dim ks As ListStream: Set ks = clone.mapListNode(iKeyIndex) Dim vs As ListStream: Set vs = mapListNode(iValueIndex) Set tMapListNode = combine(ks.list, vs.list) End Function '/** ' * Führt mittels Eval einen einen String aus. ' * ! Achtung, funktioniert nicht wenn der Rückgabewert oder die Elemente in Array oder Objekt ist ist ! ' * @example ? ListSTream(array(now, now+1)).mapEval("DateAdd('d', 15, #{value})").dump -> {0 => 26.10.2019, 1 => 27.10.2019} ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @return ListStream ' */ Public Function x__mapEval( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys Dim newValue: x__eval iStringExpr, inc(i), k, pList(k), newValue dict.add k, newValue Next Set x__mapEval = x__newLS(dict) End Function ' /** ' * @example ?ListStream("[[1,2],[3,4]]").nMapEval(1, "#{item}^2").toJSON(ltArray) -> [{0:1,1:4},{0:3,1:16}] ' * @example ?ListStream("[{a:1,b:2},{a:3,b:4}]").nMapEval("b", "#{item}^2").toJSON(ltArray) -> [{'a':1,'b':4},{'a':3,'b':16}] ' * @param Variant Index oder Key der List ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @return ListStream ' */ Public Function x__nMapEval( _ ByVal iIndex, _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim i&: i = -1 Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then Dim newValue: x__eval iStringExpr, inc(i), k, lst(subKey), newValue If IsObject(newValue) Then Set lst(subKey) = newValue Else lst(subKey) = newValue End If End If dict.add k, lst Next k Set x__nMapEval = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "x__nMapEval", iIndex, iStringExpr, iVarType Resume Exit_Handler Resume End Function 'Für Excel ist extra mapEvaluate und nicht mapEval. Diese 2 Methoden unterscheiden sich stark voneinander #If ms_product = C_ACCESS Then Public Function mapEval( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Set mapEval = x__mapEval(iStringExpr, iVarType) End Function '/** ' * mapEval wird auf den Key angewendet ' */ Public Function kMapEval( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Dim ks As Variant: ks = x__mapEval(iStringExpr, iVarType).list.items Set kMapEval = replaceKeys(ks) End Function '/* ' * mapEval für Key und Value ' */ Public Function tMapEval( _ Optional ByVal iKeyExpr As String = "#{key}", _ Optional ByVal iValueExpr As String = "#{item}" _ ) As ListStream Dim ks As ListStream: Set ks = clone.mapEval(iKeyExpr) Dim vs As ListStream: Set vs = mapEval(iValueExpr) Set tMapEval = combine(ks.list, vs.list) End Function ' /** ' * @example ?ListStream("[[1,2],[3,4]]").nMapEval(1, "#{item}^2").toJSON(ltArray) -> [{0:1,1:4},{0:3,1:16}] ' * @example ?ListStream("[{a:1,b:2},{a:3,b:4}]").nMapEval("b", "#{item}^2").toJSON(ltArray) -> [{'a':1,'b':4},{'a':3,'b':16}] ' * @param Variant Index oder Key der List ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @return ListStream ' */ Public Function nMapEval( _ ByVal iIndex, _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Set nMapEval = x__nMapEval(iIndex, iStringExpr, iVarType) End Function #ElseIf ms_product = C_EXCEL Then Public Function mapEvaluate( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Set mapEvaluate = x__mapEval(iStringExpr, iVarType) End Function '/** ' * mapEval wird auf den Key angewendet ' */ Public Function kMapEvaluate( _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Dim ks As Variant: ks = mapEvaluate(iStringExpr, iVarType).list.items Set kMapEvaluate = replaceKeys(ks) End Function '/* ' * mapEval für Key und Value ' */ Public Function tMapEvaluate( _ Optional ByVal iKeyExpr As String = "#{key}", _ Optional ByVal iValueExpr As String = "#{item}" _ ) As ListStream Dim ks As ListStream: Set ks = clone.mapEvaluate(iKeyExpr) Dim vs As ListStream: Set vs = mapEvaluate(iValueExpr) Set tMapEvaluate = combine(ks.list, vs.list) End Function ' /** ' * @example ?ListStream("[[1,2],[3,4]]").nMapEval(1, "#{item}^2").toJSON(ltArray) -> [{0:1,1:4},{0:3,1:16}] ' * @example ?ListStream("[{a:1,b:2},{a:3,b:4}]").nMapEval("b", "#{item}^2").toJSON(ltArray) -> [{'a':1,'b':4},{'a':3,'b':16}] ' * @param Variant Index oder Key der List ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @return ListStream ' */ Public Function nMapEvaluate( _ ByVal iIndex, _ Optional ByVal iStringExpr As String = "#{item}", _ Optional ByVal iVarType As VbVarType = vbVariant _ ) As ListStream Set nMapEvaluate = x__nMapEval(iIndex, iStringExpr, iVarType) End Function #End If '/** ' * Führt den eval (access) oder Evaluate (Excel) aus ' */ Private Function x__eval(ByVal iStringExpr, ByVal iIndex As Long, ByVal iKey, ByRef iValue, ByRef oResult, Optional ByVal iVarType As VbVarType = vbVariant) As Boolean On Error GoTo Err_Handler Dim origVarType As VbVarType: origVarType = varType(iValue) x__eval = True 'On Error Resume Next Dim evalStr$: evalStr = x__nodeToString(iStringExpr, var2CodeStr(iKey), var2CodeStr(iValue), iIndex, iVarType, False) #If ms_product = C_ACCESS Then Dim lsRetem: ref lsRetem, Application.eval(evalStr) #ElseIf ms_product = C_EXCEL Then evalStr = replace(evalStr, "'", """") Dim lsRetem: ref lsRetem, Application.Evaluate(evalStr) #End If 'If Err.Number <> 0 Then ' oResult = "Eval-Error #" & Err.Number & " " & Err.Description & " : " & evalStr 'Else On Error GoTo 0 If IsObject(lsRetem) Then Set oResult = lsRetem ElseIf iVarType <> vbVariant Then oResult = x__castValue(pList(iKey), iVarType) Else oResult = lsRetem End If 'End If x__eval = True Exit_Handler: Exit Function Err_Handler: If Err.Number = 2438 Then oResult = "Invalid Expresseion: " & evalStr Resume Next End If handleError Err, "x__eval", iStringExpr, iIndex, iKey, iValue, iVarType Resume Exit_Handler Resume End Function #If ms_product = C_ACCESS Then '/** ' * Führt ein User Defined Function (udf) auf jedes Element durch. Geht auch mit einigen VBA-Funktionen ' * @example .mapWalk('myFunction', 10, "#{item}", "#{key}") ' * @example ? ListStream(array("20190101", "20191231")).mapWalk("strToDate", "#{item}", "yyyymmdd").dump -> {0 => 01.01.2019, 1 => 31.12.2019} ' * @example ? ListStream(array(1,2,3)).mapWalk("format", "#{item}", "'0.00'").dump -> {0 => 1.00, 1 => 2.00, 2 => 3.00} ' * @param String Name der Funktion ' * @param ParamArray Argumente (in Code-Form), Platzhalter(kein String-Parsing, nur ein String mit dem Platzhalter, damit da der Wert eingefügt wird) ' * @return ListStream ' */ Public Function mapWalk(ByVal iUdfName As String, ParamArray iArgs() As Variant) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set mapWalk = mapWalkA(iUdfName, args) End Function Public Function kMapWalk(ByVal iUdfName As String, ParamArray iArgs() As Variant) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set kMapWalk = kMapWalkA(iUdfName, args) End Function Public Function kMapWalkA(ByVal iUdfName As String, ByRef iArgs() As Variant) As ListStream Dim ks: ks = mapWalkA(iUdfName, iArgs).list.items Set kMapWalkA = replaceKeys(ks) End Function Public Function mapWalkA(ByVal iUdfName As String, ByRef iArgs() As Variant) As ListStream On Error GoTo Err_Handler Dim tryUdf As Boolean: tryUdf = True Dim v() As Variant Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList v = x__replaceArgs(k, pList(k), inc(i), iArgs) dict.add k, callUdfByArray(iUdfName, v) Next GoTo Exit_Handler alter: tryUdf = False For Each k In pList v = x__replaceArgs(k, var2CodeStr(pList(k)), inc(i), iArgs) Dim code As String: code = iUdfName & "(" & VBA.join(v, ", ") & ")" dict.add k, Application.eval(code) Next Exit_Handler: Set mapWalkA = x__newLS(dict) Exit Function Err_Handler: If tryUdf Then Resume alter handleError Err, "mapWalkA", iUdfName, iArgs Resume Exit_Handler Resume End Function #End If '/** ' * Führt eine Methode auf allen Objekten einer Liste durch ' * @example ? ListStream(array(DateTime())).mapCallObjMethode("add", VbMethod, "P5D").mapObiProp("dateValue", VbGet).dump -> {0 => 16.10.2019} ' * @param String Name der Methode/Getter ' * @param vbCallType Art der Proc ' * @param ParamArray Argumente, Platzhalter(kein String-Parsing, nur ein String mit dem Platzhalter, damit da der Wert eingefügt wird) ' * @return ListStream ' */ Public Function mapCallObjMethode( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ParamArray iArgs() As Variant _ ) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set mapCallObjMethode = mapCallObjMethodeA(iProcName, iCallType, args) End Function Public Function mapCallObjMethodeA( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ByRef iArgs() As Variant _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__cloneDict Dim i&: i = -1 Dim k: For Each k In dict inc i If IsObject(dict(k)) Then If isArrayValid(iArgs) Then callByNameA dict(k), iProcName, iCallType, x__replaceArgs(k, dict(k), i, iArgs) Else CallByName dict(k), iProcName, iCallType End If End If Next Set mapCallObjMethodeA = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapCallObjMethodeA", iProcName, iCallType, iArgs Resume Exit_Handler Resume End Function '/** ' * Ersetzt die Items einer Liste durch den Rückgabewert eine itemProperty oder einer itemMethode ' * @example ? ListStream(array(DateTime())).mapObiProp("dateValue", VbGet).dump -> {0 => 10.11.2019} ' * @example ? ListStream(array(DateTime())).mapObiProp("format", VbMethod, "YYYYMMDD").dump -> {0 => 20191011} ' * @param String Name der Methode/Getter ' * @param vbCallType Art der Proc ' * @param ParamArray Argumente, Platzhalter(kein String-Parsing, nur ein String mit dem Platzhalter, damit da der Wert eingefügt wird) ' * @return ListStream ' */ Public Function mapObiProp( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ParamArray iArgs() As Variant _ ) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set mapObiProp = mapObiPropA(iProcName, iCallType, args) End Function Public Function mapObiPropA( _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ByRef iArgs() As Variant _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys inc i If isArrayValid(iArgs) Then dict.add k, callByNameA(pList(k), iProcName, iCallType, x__replaceArgs(k, pList(k), i, iArgs)) Else dict.add k, CallByName(pList(k), iProcName, iCallType) End If Next Set mapObiPropA = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "mapObiPropA", iProcName, iCallType, iArgs Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- ' -- Filter Methodes ' Reduziert die Anzahl einträge (filtern) '------------------------------------------------------------------------------- '/** ' * Filtert eine Liste von Objekten anhand einer Methode oder eines Properties der Klasse ' * @param Variant Vergleichswert ' * @param String Name der Methode/Getter ' * @param vbCallType Art der Proc ' * @param ParamArray Argumente, Platzhalter(kein String-Parsing, nur ein String mit dem Platzhalter, damit da der Wert eingefügt wird) ' * @return ListStream ' */ Public Function filterByObjProp( _ ByRef iArg As Variant, _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ParamArray iArgs() As Variant _ ) As ListStream Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) Set filterByObjProp = filterByObjPropA(iArg, iProcName, iCallType, args) End Function Public Function filterByObjPropA( _ ByRef iArg As Variant, _ ByVal iProcName As String, _ ByVal iCallType As VbCallType, _ ByRef iArgs() As Variant _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys inc i If isArrayValid(iArgs) Then If iArg = callByNameA(pList(k), iProcName, iCallType, x__replaceArgs(k, pList(k), i, iArgs)) Then dict.add k, pList(k) Else If iArg = CallByName(pList(k), iProcName, iCallType) Then dict.add k, pList(k) End If Next Set filterByObjPropA = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterByObjPropA", iArg, iProcName, iCallType, iArgs Resume Exit_Handler Resume End Function '/** ' * Zählt gleiche Elemente ' * @example ? ListStream("[a,a,b,b,c,1,a]").countValues().dump -> {a => 3, b => 2, c => 1, 1 => 1} ' * @return ListStream ' */ Public Function countValues(Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim k: For Each k In pList Dim item As Variant: ref item, pList(k) If x__nCM(iCompareMode) = vbTextCompare Then item = x__castValue(item, vbString) If Not dict.exists(item) Then dict.add item, 1 Else dict(item) = dict(item) + 1 End If Next Set countValues = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "countValues", iCompareMode Resume Exit_Handler Resume End Function '/** ' * entfernt doppelte Einträge (Values) ' * @example ? ListSTream(array(1,2,1,4)).unique().dump -> {0 => 1, 1 => 2, 3 => 4} ' * @param Boolean ' * @param compaireMethod ' * @return ListStream ' */ Public Function unique( _ Optional ByVal iResetIndex As Boolean = False, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim index As Object: Set index = x__createDict(iCompareMode) Dim k: For Each k In pList Dim item As Variant: ref item, pList(k) If x__nCM(iCompareMode) = vbTextCompare Then item = x__castValue(item, vbString) If Not index.exists(item) Then dict.add k, pList(k): index.add item, True Next Set unique = x__newLS(dict) If iResetIndex Then Set unique = unique.resetIndex Exit_Handler: Exit Function Err_Handler:: handleError Err, "unique", iResetIndex, iCompareMode Resume Exit_Handler Resume End Function Public Function nUnique( _ ByVal iIndex, _ Optional ByVal iResetIndex As Boolean = False, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict(iCompareMode) Dim index As Object: Set index = x__createDict(iCompareMode) Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then Dim item As Variant: ref item, lst(subKey) If x__nCM(iCompareMode) = vbTextCompare Then item = x__castValue(item, vbString) If Not index.exists(item) Then dict.add k, pList(k): index.add item, True End If Next k Set nUnique = x__newLS(dict) If iResetIndex Then Set nUnique = nUnique.resetIndex Exit_Handler: Exit Function Err_Handler: handleError Err, "nSum", iIndex Resume Exit_Handler Resume End Function '/** ' * Entfernt alle leeren Einträge (Null, Empty, Nothing, leerer Array etc) ' * Siehe https://wiki.yaslaw.info/doku.php/vba/functions/isnothing ' * @example ? ListSTream(array(1,null,empty,4)).trim().dump -> {0 => 1, 3 => 4} ' * @param Boolean ' * @return ListStream ' */ Public Function trim(Optional ByVal iResetIndex As Boolean = False) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim k: For Each k In pList.keys If Not isNothing(pList(k)) Then dict.add k, pList(k) Next Set trim = x__newLS(dict) If iResetIndex Then Set trim = trim.resetIndex Exit_Handler: Exit Function Err_Handler:: handleError Err, "trim", iResetIndex Resume Exit_Handler Resume End Function Public Function nTrim( _ ByVal iIndex, _ Optional ByVal iResetIndex As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then Dim item As Variant: ref item, lst(subKey) If Not isNothing(item) Then dict.add k, pList(k) End If Next k Set nTrim = x__newLS(dict) If iResetIndex Then Set nTrim = nTrim.resetIndex Exit_Handler: Exit Function Err_Handler: handleError Err, "nSum", iIndex Resume Exit_Handler Resume End Function Public Function nFilterIsNothing( _ ByVal iIndex, _ Optional ByVal iResetIndex As Boolean = False, _ Optional ByVal iParams As enuIsNothingParams = isnDefault _ ) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then Dim item As Variant: ref item, lst(subKey) Select Case TypeName(item) Case "Null": If andB(iParams, isnNull) Then dict.add k, pList(k) Case "Empty": If andB(iParams, isnEmtpy) Then dict.add k, pList(k) Case "Nothing": If andB(iParams, isnNothing) Then dict.add k, pList(k) Case "String": If andB(iParams, isnSpaces) And Len(VBA.trim(item)) = 0 Then dict.add k, pList(k) ElseIf andB(iParams, isnNullString) And Len(item) = 0 Then dict.add k, pList(k) End If Case "Collection", "Dictionary", "ListStream": If andB(iParams, isnEmptyList) And item.count = 0 Then dict.add k, pList(k) Case "Iterator": If andB(iParams, isnEmptyList) And Not item.isInitialized Then dict.add k, pList(k) '//TODO: weitere Spezialfälle Case Else: If andB(iParams, isnEmptyList) And IsArray(item) Then If UBound(item) < LBound(item) Then dict.add k, pList(k) If IsNumeric(item) Then If andB(iParams, isnZero) And item = 0 Then dict.add k, pList(k) End Select End If Next k Set nFilterIsNothing = x__newLS(dict) If iResetIndex Then Set nFilterIsNothing = nFilterIsNothing.resetIndex Exit_Handler: Exit Function Err_Handler: handleError Err, "nSum", iIndex Resume Exit_Handler Resume End Function #If ms_product = C_ACCESS Then '/** ' * Filtert alle Werte nach einem eval ' * @example ? ListSTream(array(1,2,3,4)).filterByEval("(#{value} mod 2) = 0").dump -> {1 => 2, 3 => 4} ' * @param String Pattern -> Siehe Patternbeschreibung am Anfag des Moduls ' * @return ListStream ' */ Public Function filterByEval(ByVal iStringExpr As String) As ListStream On Error GoTo Err_Handler Dim dict As Object: Set dict = x__createDict Dim i&: i = -1 Dim k: For Each k In pList.keys Dim evalStr As String: evalStr = x__nodeToString(iStringExpr, k, pList(k), inc(i)) If CBool(Application.eval(evalStr)) Then dict.add k, pList(k) Next Set filterByEval = x__newLS(dict) Exit_Handler: Exit Function Err_Handler: handleError Err, "filterByEval", iStringExpr Resume Exit_Handler Resume End Function #End If ' --------------------------------------------- ' ---- filterByValue ' --------------------------------------------- '/** ' * Filter: Filtert alle Werte ' * @example ? ListSTream(array(1,null,empty,4)).filterByValue(1, acGreaterThan).dump -> {3 => 4} ' * @example ? ListSTream.range(1,10).filterByValue(3, acBetween, 5).dump -> {2 => 3, 3 => 4, 4 => 5} ' * @param Variant Wert mit dem verglichen werden soll ' * @param acFormatConditionOperator Vergleichsoperator ' * @param Variant Zweiter Wert für einen Betweenvergleich ' * @param Variant Null Vergleichswert ' * @return ListStream ' */ Public Function filterByValue( _ ByVal iFilterValue As Variant, _ Optional iCondition As enuCondition = coEqual, _ Optional ByVal iFilterValueTo As Variant = "N/A", _ Optional ByVal iNullCompaireValue As Variant = Empty _ ) As ListStream On Error GoTo Err_Handler If IsObject(iFilterValue) Or IsObject(iFilterValueTo) Then Err.Raise 13 Dim dict As Object: Set dict = x__createDict Dim item As Variant iFilterValue = NZ(iFilterValue, iNullCompaireValue) Dim k: For Each k In pList.keys Dim flag As Boolean item = NZ(pList(k), iNullCompaireValue) If CompareMode = vbTextCompare Then item = x__castValue(item, varType(iFilterValue)) Select Case iCondition Case coEqual: flag = (item = iFilterValue) Case coNotEqual: flag = Not (item = iFilterValue) Case coGreaterThan: flag = (item > iFilterValue) Case coGreaterThanOrEqual: flag = (item >= iFilterValue) Case coLessThan: flag = (item < iFilterValue) Case coLessThanOrEqual: flag = (item >= iFilterValue) Case coBetween: flag = (item >= iFilterValue And iFilterValueTo >= item) Case coNotBetween: flag = Not (item >= iFilterValue And iFilterValueTo >= item) Case Else: flag = True End Select If flag Then dict.add k, pList(k) Next Set filterByValue = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterByValue", iFilterValue, iCondition, iFilterValueTo, iNullCompaireValue Resume Exit_Handler Resume End Function Public Function kFilterByValue( _ ByVal iFilterValue As Variant, _ Optional iCondition As enuCondition = coEqual, _ Optional ByVal iFilterValueTo As Variant = "N/A" _ ) As ListStream Dim ks: ks = keys.filterByValue(iFilterValue, iCondition, iFilterValueTo).list.keys Set kFilterByValue = filterInList(ks, wwIndex) End Function Public Function findByValue(ByVal iFilterValue As Variant, Optional iCondition As enuCondition = coEqual, Optional ByVal iFilterValueTo As Variant = "N/A", Optional ByVal iNullCompaireValue As Variant = Empty) As Variant ref findByValue, filterByValue(iFilterValue, iCondition, iFilterValueTo, iNullCompaireValue).first End Function Public Function kFindByValue(ByVal iFilterValue As Variant, Optional iCondition As enuCondition = coEqual, Optional ByVal iFilterValueTo As Variant = "N/A") As Variant ref kFindByValue, kFilterByValue(iFilterValue, iCondition, iFilterValueTo).first End Function '/** ' * Sucht nach einem Value und gibt den ersten passenden Key zurück ' * @example ? ListStream("{a:1,b:3,c:6}").search("6") -> c ' * @param Variant Wert mit dem verglichen werden soll ' * @param acFormatConditionOperator Vergleichsoperator ' * @param Variant Zweiter Wert für einen Betweenvergleich ' */ Public Function search(ByVal iFilterValue As Variant, Optional iCondition As enuCondition = coEqual, Optional ByVal iFilterValueTo As Variant = "N/A") As Variant Dim ls As ListStream: Set ls = filterByValue(iFilterValue, iCondition, iFilterValueTo) search = IIf(ls.count = 0, False, ls.getKeySpecial(byFirst)) End Function '/** ' * deprecated: Wird abgelöst durch nFilterByValue() ' */ Public Function filterListNode(ByVal iIndex, ByVal iFilterValue As Variant, Optional iCondition As enuCondition = coEqual, Optional ByVal iFilterValueTo As Variant = "N/A", Optional ByVal iNullCompaireValue As Variant = Empty) As ListStream Set filterListNode = nFilterByValue(iIndex, iFilterValue, iCondition, iFilterValueTo, iNullCompaireValue) End Function '/** ' * Die Items sind selber Listen. Die Funktion Filtert nach Werten an der xten (index oder Key) Postion ' * @example: ? ListStream("{a:[A1,A2], b:[A1,B2]}").nFilter("1", "A2").json -> {'a':['A1','A2']} ' * ? ListStream("{a:[A1,2], b:[A1,3], c:[C2,10]}").nFilter(1, 2, coBetween, 3).json -> {'a':['A1',2],'b':['A1',3]} ' * ? ListStream("{a:{x:A1,y:A2}, b:{x:A1,y:B2}}").filterListNode("y", "A2").json -> {'a':{'x':'A1','y':'A2'}} ' * @param Variant Index oder Key der Sublist ' * @param Variant Wert mit dem verglichen werden soll ' * @param acFormatConditionOperator Vergleichsoperator ' * @param Variant Zweiter Wert für einen Betweenvergleich ' * @param Variant Null Vergleichswert ' * @return ListStream ' */ Public Function nFilterByValue( _ ByVal iIndex, _ ByVal iFilterValue As Variant, _ Optional iCondition As enuCondition = coEqual, _ Optional ByVal iFilterValueTo As Variant = "N/A", _ Optional ByVal iNullCompaireValue As Variant = Empty _ ) As ListStream On Error GoTo Err_Handler If IsObject(iFilterValue) Or IsObject(iFilterValueTo) Then Err.Raise 13 Dim dict As Object: Set dict = x__createDict Dim item As Variant Dim flag As Boolean Dim subKey iFilterValue = NZ(iFilterValue, iNullCompaireValue) Dim k: For Each k In pList.keys If Not x__getItemFromListNode(iIndex, pList(k), item) Then GoTo Continue_For If CompareMode = vbTextCompare Then item = x__castValue(item, varType(iFilterValue)) Select Case iCondition Case coEqual: flag = (item = iFilterValue) Case coNotEqual: flag = Not (item = iFilterValue) Case coGreaterThan: flag = (item > iFilterValue) Case coGreaterThanOrEqual: flag = (item >= iFilterValue) Case coLessThan: flag = (item < iFilterValue) Case coLessThanOrEqual: flag = (item >= iFilterValue) Case coBetween: flag = (item >= iFilterValue And iFilterValueTo >= item) Case coNotBetween: flag = Not (item >= iFilterValue And iFilterValueTo >= item) Case Else: flag = True End Select If flag Then dict.add k, pList(k) Continue_For: Next Set nFilterByValue = x__newLS(dict) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterListNode", iIndex, iFilterValue, iCondition, iFilterValueTo, iNullCompaireValue Resume Exit_Handler Resume End Function '/** ' * Führt einen RegExp Replace auf jedes Element aus ' * @param String Pattern (gemäss https://wiki.yaslaw.info/doku.php/vba/cast/cregexp) ' * @param iComparePart Was verglichen werden soll. Key, Indey oder Wert ' * @param iNot Negative Liste. "Not In" ' * @return ListStream ' */ Public Function filterByRegEx( _ ByVal iPattern As String, _ Optional ByVal iComparePart As enuWorkWith = wwValue, _ Optional ByVal iNot As Boolean = False _ ) As ListStream On Error GoTo Err_Handler Dim rx As Object: Set rx = cRx(iPattern) Dim trg As Object: Set trg = x__createDict Dim i As Long: i = -1 Dim flg As Boolean Dim k: For Each k In pList.keys Select Case iComparePart Case wwIndex: flg = rx.test(CStr(inc(i))) Case wwKey: flg = rx.test(CStr(NZ(k, C_NULL))) Case wwValue: flg = rx.test(CStr(NZ(pList(k)))) End Select If flg = Not iNot Then trg.add k, pList(k) Next k Set filterByRegEx = x__newLS(trg) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterByRegEx", iPattern, iComparePart, iNot Resume Exit_Handler Resume End Function ' --------------------------------------------- ' ---- filterInList ' --------------------------------------------- '/** ' * Filter: Filtert anhand der Werte einer Liste. Auch bei einem Dictionary und Key-Vergleich wird der Key vom Original mit dem Wert der Liste verglichen ' * @example ? ListStream("{a:1,b:2,c:3,d:4}").filterInList(array(1, 3), wwIndex).dump -> {b => 2, d => 4} ' * @example ? ListStream("{a:1,b:2,c:3,d:4}").filterInList(Array(1, 3), wwIndex, True).dump -> {a => 1, c => 3} ' * @example ? ListStream("{a:1,b:2,c:3,d:4}").filterInList(Array("a", "d"), wwKey).dump -> {a => 1, d => 4} ' * @example ? ListStream("{a:1,b:2,c:3,d:4}").filterInList(Array(1, 3), wwValue).dump -> {a => 1, c => 3} ' * @param Variant zu vergleichende Liste ' * @param iComparePart Was verglichen werden soll. Key, Indey oder Wert ' * @param iNot Negative Liste. "Not In" ' * @param compaireMethod ' * @return ListStream ' */ Public Function filterInList( _ ByRef iList As Variant, _ Optional ByVal iComparePart As enuWorkWith = wwIndex, _ Optional ByVal iNot As Boolean = False, _ Optional ByVal iCompareMode As Integer = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim cm As Integer: cm = x__nCM(iCompareMode) Dim flt As Object: Set flt = x__flipDict(x__toDict(iList, cm), iComparePart = wwKey And cm = vbTextCompare, True, cm) Dim trg As Object: Set trg = x__createDict Dim srcKeys As Variant: srcKeys = pList.keys Dim i As Long: i = -1 Dim flg As Boolean Dim k As Variant: For Each k In pList.keys If cm = vbTextCompare Then Select Case iComparePart Case wwIndex: flg = flt.exists(inc(i)) Case wwKey: flg = flt.exists(CStr(NZ(k, C_NULL))) Case wwValue: flg = flt.exists(NZ(pList(k), C_NULL)) End Select Else Select Case iComparePart Case wwIndex: flg = flt.exists(inc(i)) Case wwKey: flg = flt.exists(NZ(k, C_NULL)) Case wwValue: flg = flt.exists(NZ(pList(k), C_NULL)) End Select End If If flg = Not iNot Then trg.add k, pList(k) Next k Set filterInList = x__newLS(trg) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterInList", iList, iComparePart, iNot, iCompareMode Resume Exit_Handler Resume End Function '/** ' * Analog zu filterInList, es werden aber Wert & Key/Index verglichen ' * @example ? listStream("{a:1,b:2,c:3}").filterInListAssoc("{a:2,c:3,b:2}").dump -> {b => 2, c => 3} ' * @example ? listStream("[a,b,c]").filterInListAssoc("[a,c]").dump -> {0 => a} ' */ Public Function filterInListAssoc( _ ByRef iList As Variant, _ Optional ByVal iNot As Boolean = False, _ Optional ByVal iCompareMode As Integer = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim cm As Integer: cm = x__nCM(iCompareMode) Dim trg As Object: Set trg = x__createDict Dim comp As Object: Set comp = x__toDict(iList, cm) Dim srcKeys As Variant: srcKeys = pList.keys Dim i As Long: i = -1 Dim flg As Boolean Dim k As Variant: For Each k In pList.keys flg = comp.exists(k) If flg Then flg = pList(k) = comp(k) If flg = Not iNot Then trg.add k, pList(k) Next k Set filterInListAssoc = x__newLS(trg) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterInListAssoc", iList, iNot, iCompareMode Resume Exit_Handler Resume End Function 'Aliase zu filterInList 'Index Public Function inList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set inList = filterInList(iList, wwIndex, False, iCompareMode) End Function Public Function notInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set notInList = filterInList(iList, wwIndex, True, iCompareMode) End Function 'key Public Function kInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set kInList = filterInList(iList, wwKey, False, iCompareMode) End Function Public Function kNotInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set kNotInList = filterInList(iList, wwKey, True, iCompareMode) End Function 'value Public Function vInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set vInList = filterInList(iList, wwValue, False, iCompareMode) End Function Public Function vNotInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set vNotInList = filterInList(iList, wwValue, True, iCompareMode) End Function 'key & value Public Function tInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set tInList = filterInListAssoc(iList, False, iCompareMode) End Function Public Function tNotInList(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set tNotInList = filterInListAssoc(iList, True, iCompareMode) End Function 'PHP aliases 'Public Function intersect(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream ' Set intersect = filterInList(iList, wwValue, False, iCompareMode) 'End Function Public Function intersectKey(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set intersectKey = filterInList(iList, wwKey, False, iCompareMode) End Function Public Function intersectAssoc(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set intersectAssoc = filterInListAssoc(iList, False, iCompareMode) End Function 'Public Function diff(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream ' Set diff = filterInListAssoc(iList, True, iCompareMode) 'End Function Public Function diffKey(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set diffKey = filterInList(iList, wwKey, True, iCompareMode) End Function Public Function diffAssoc(ByRef iList As Variant, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set diffAssoc = filterInListAssoc(iList, True, iCompareMode) End Function '/** ' * deprecated: Wird abgelöst durch nFilterInList() ' */ Public Function filterInListNode(ByVal iIndex, ByRef iList As Variant, Optional ByVal iNot As Boolean = False, Optional ByVal iCompareMode As Integer = C_NOT_DEFINED) As ListStream Set filterInListNode = nFilterInList(iIndex, iList, iNot, iCompareMode) End Function '/** ' * Filtert nach einem Item innerhalb von Unterlisten. Analog zu filterObjProp() ' * @example: ? ListStream("[{a:1,b:2},{a:2,b:2}]").nFilterInList("a",array(1,3)).json -> {0:{'a':1,'b':2}} ' * @param Variant Index oder Key der Sublist ' * @param Variant Liste mit gültigen Werten ' * @param iNot Negative Liste. "Not In" ' * @param compaireMethod ' * @return ListStream ' */ Public Function nFilterInList( _ ByVal iIndex, _ ByRef iList As Variant, _ Optional ByVal iNot As Boolean = False, _ Optional ByVal iCompareMode As Integer = C_NOT_DEFINED _ ) As ListStream On Error GoTo Err_Handler Dim cm As Integer: cm = x__nCM(iCompareMode) Dim flt As Object: Set flt = x__flipDict(x__toDict(iList, cm)) Dim trg As Object: Set trg = x__createDict Dim item Dim k: For Each k In pList.keys If Not x__getItemFromListNode(iIndex, pList(k), item) Then GoTo Continue_For If flt.exists(NZ(item, C_NULL)) Then trg.add k, pList(k) Continue_For: Next k Set nFilterInList = x__newLS(trg) Exit_Handler: Exit Function Err_Handler:: handleError Err, "filterInListNode", iIndex, iList, iNot, iCompareMode Resume Exit_Handler Resume End Function '/** ' * Gibt ein Item aus ener Unteliste zurück ' * @param Variant Index oder Key der Sublist ' * @param Variant Liste mit gültigen Werten ' * @param (out) Variant Item an besagter Position ' * @return Boolean ' */ Private Function x__getItemFromListNode(ByVal iIndex, ByRef iLst, ByRef oItem) As Boolean Dim lst As Object: Set lst = x__toDict(iLst) Dim subKey If IsNumeric(iIndex) Then Dim subKeys: subKeys = lst.keys If CLng(iIndex) < 0 Or CLng(iIndex) >= lst.count Then Exit Function subKey = subKeys(CLng(iIndex)) Else If Not lst.exists(iIndex) Then Exit Function subKey = iIndex End If ref oItem, lst(subKey) x__getItemFromListNode = True End Function '------------------------------------------------------------------------------- ' -- Cast Properties ' Wandelt die Liste in einen Andere um '------------------------------------------------------------------------------- '/** ' * Wandelt die list in ein Array ' * @param vbVarType Typ des Arrays ' * @return Array ' */ Public Function toArray(Optional ByVal iVarType As VbVarType = vbVariant) As Variant On Error GoTo Err_Handler Dim retArr As Variant retArr = emptyArray(iVarType, pList.count - 1) Dim i&: i = -1 Dim k: For Each k In pList.keys If iVarType = vbVariant Then ref retArr(inc(i)), pList(k) Else retArr(inc(i)) = x__castValue(pList(k), iVarType) Next toArray = retArr Exit_Handler: Exit Function Err_Handler:: handleError Err, "toArray", iVarType Resume Exit_Handler Resume End Function '/** ' * Wandelt in eine andere Art von Liste ' * @param enuListType Art der Liste ' * @return Collection ' */ Public Function toCollection(Optional ByVal iVarType As VbVarType = vbVariant) As Collection On Error GoTo Err_Handler Set toCollection = New Collection Dim k: For Each k In pList If iVarType = vbVariant Then toCollection.add pList(k), x__castValue(k) Else toCollection.add x__castValue(pList(k), iVarType), x__castValue(k) Next Exit_Handler: Exit Function Err_Handler:: handleError Err, "toCollection", iVarType Resume Exit_Handler Resume End Function '/** ' * Wandelt in eine andere Art von Liste ' * @param enuListType Art der Liste ' * @return Dictionary ' */ Public Function toDictionary(Optional ByVal iVarType As VbVarType = vbVariant) As Object If iVarType = vbVariant Then Set toDictionary = list Else Set toDictionary = mapCast(iVarType).list End Function '/** ' * Wandelt in eine andere Art von Liste ' * @param enuListType Art der Liste ' * @param itParams Paramter des Iterators ' * @return Iterator ' */ #If iterator Then Public Function toIterator(Optional ByVal iVarType As VbVarType = vbVariant, Optional ByVal iIteratorParams As itParams = itParams.itDefault) As iterator Dim dict: Set dict = IIf(iVarType = vbVariant, list, mapCast(iVarType).list) Set toIterator = iterator.instance(dict, iIteratorParams) End Function #End If '/** ' * Wandelt in eine andere Art von Liste ' * @param enuListType Art der Liste ' * @return Dictionary ' */ #If JSF Then Public Function toJsf(Optional ByVal iVarType As VbVarType = vbVariant, Optional ByVal iJsfParams As jsfParams = jsfParams.[_Default]) As JSF Dim dict: Set dict = IIf(iVarType = vbVariant, list, mapCast(iVarType).list) Set toJsf = JSF(dict, , iJsfParams) End Function #End If '------------------------------------------------------------------------------- ' -- Reduce Methodes ' Reduziert die LIste auf einen Wert '------------------------------------------------------------------------------- '/** ' * Iterative Reduktion eines Arrays zu einem Wert mittels einer RegReplace ' * Die Funktion mimmt die Keys der liste als Suchpattern und den Wert als Ersetzungspattern und wendet diese auf den Eingabestring an ' * @example ' * ? ListStream.combine("[ä,ö,ü]", "[ae,oe,ue]").parseByRegExReplace("Hüser bränned mit Für") -> Hueser braenned mit Fuer ' * @param String Functionsname ' * @param lsRxFlagsEnum Reg-Ex Flags, die für alle Patterns gelten gelten. Überschreibt die Patterns der der Keys. Globals ist immr gesetzt. ' * @retrun Variant ' */ Public Function parseByRegExReplace(ByVal iStringExpr As String, Optional ByVal iRegExParams As lsRxFlagsEnum = lsRxNotDefined) As String On Error GoTo Err_Handler parseByRegExReplace = iStringExpr Dim ls As Object: Set ls = mapToStr().list Dim k: For Each k In ls.keys Dim rx As Object: Set rx = cRx(k) If iRegExParams > lsRxNotDefined Then rx.IgnoreCase = andB(iRegExParams, lsRxIgnoreCase) rx.Multiline = andB(iRegExParams, lsRxMultiline) End If rx.Global = True parseByRegExReplace = rx.replace(parseByRegExReplace, ls(k)) Next k Exit_Handler: Exit Function Err_Handler: handleError Err, "parseByRegExReplace", iStringExpr, iRegExParams Resume Exit_Handler Resume End Function '/** ' * Iterative Reduktion eines Arrays zu einem Wert mittels einer Callback Funktion ' * Die Funktion muss als erste 2 Argumente die Werte haben ' * @Example ' * Public Function streamUdfTest(a, b, Optional c = 0) As Long ' * streamUdfTest = a^c + b^c ' * End Function ' * ? ListStream(array(1,2,3)).reduceByUdf("streamUdfTest",3) --> 756 ' * @param String Functionsname ' * @param ParamArray Weitere Paamter ' * @retrun Variant ' */ Public Function reduceByUdf(ByVal iUdfName As String, ParamArray iArgs() As Variant) As Variant Dim args() As Variant: If UBound(iArgs) > -1 Then args = CVar(iArgs) reduceByUdf = reduceByUdfA(iUdfName, args) End Function Public Function reduceByUdfA(ByVal iUdfName As String, ByRef iArgs() As Variant) As Variant On Error GoTo Err_Handler If isArrayValid(iArgs) Then ReDim Preserve iArgs(0 To UBound(iArgs) + 2) Dim i&: For i = UBound(iArgs) To 2 Step -1 iArgs(i) = iArgs(i - 2) Next i Else ReDim iArgs(1) End If reduceByUdfA = Null i = -1 Dim k: For Each k In pList.keys iArgs(0) = reduceByUdfA iArgs(1) = pList(k) reduceByUdfA = callUdfByArray(iUdfName, iArgs) Next Exit_Handler: Exit Function Err_Handler: handleError Err, "reduceByUdfA", iUdfName, iArgs Resume Exit_Handler Resume End Function '/** ' * Fügt alle Values zu einem String zusammen. Analog zu join() ' * @param Delimiter ' * @return String ' */ Public Function join(Optional ByVal iDelimiter As String = Empty) As String join = VBA.join(toArray, iDelimiter) End Function ' * Alias zu join() Public Function concat(Optional ByVal iDelimiter As String = Empty) As String: concat = join(iDelimiter): End Function '/** ' * Berechnet die Summe von allen numerischen Werten. Nicht numerische Werte werden al 0 gerechnet ' * @return Number ' */ Public Function sum() As Variant On Error GoTo Err_Handler sum = 0 Dim k: For Each k In pList.keys If IsNumeric(pList(k)) Then sum = sum + pList(k) End If Next Exit_Handler: Exit Function Err_Handler:: handleError Err, "sum" Resume Exit_Handler Resume End Function '/** ' * Berechnet die Summe von allen numerischen Werten in einer Unterliste. Nicht numerische Werte werden al 0 gerechnet ' * @param Variant Key oder Index ' * @return Number ' */ Public Function nSum(ByVal iIndex) As Variant On Error GoTo Err_Handler nSum = 0 Dim dict As Object: Set dict = x__createDict Dim lst As Object, subKey Dim k: For Each k In pList.keys Set lst = x__toDict(pList(k), , , , False) If x__getKey(iIndex, subKey, lst) Then nSum = nSum + (lst(subKey)) Next k Exit_Handler: Exit Function Err_Handler: handleError Err, "nSum", iIndex Resume Exit_Handler Resume End Function '/** ' * Den Ersten Eintrag ' * @return Variant ' */ Public Function first() As Variant On Error GoTo Err_Handler If pList.count = 0 Then first = Null: Exit Function Dim ks: ks = pList.keys ref first, pList(ks(0)) Exit_Handler: Exit Function Err_Handler:: handleError Err, "first" Resume Exit_Handler Resume End Function '/** ' * Den Ersten Eintrag ' * @return letzten ' */ Public Function last() As Variant On Error GoTo Err_Handler If pList.count = 0 Then last = Null: Exit Function Dim ks: ks = pList.keys ref last, pList(ks(UBound(ks))) Exit_Handler: Exit Function Err_Handler:: handleError Err, "last" Resume Exit_Handler Resume End Function '/** ' * Info, dass die aktuelle Position nach dem Ende ist ' * @return Boolean ' */ Public Property Get EOF() As Boolean On Error GoTo Err_Handler EOF = True If count = 0 Then Exit Property If pPos > count - 1 Then pPos = count: Exit Property EOF = False Exit_Handler: Exit Property Err_Handler:: handleError Err, "EOF" Resume Exit_Handler Resume End Property '/** ' * Info, dass die aktuelle Position vor dem ANfang ist ' * @return Boolean ' */ Public Property Get BOF() As Boolean On Error GoTo Err_Handler BOF = True If count = 0 Then Exit Property If pPos < 0 Then pPos = -1: Exit Property BOF = False Exit_Handler: Exit Property Err_Handler:: handleError Err, "BOF" Resume Exit_Handler Resume End Property '/** ' * Eins Vorrücken und Erfolg zurückgeben ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @return Boolean ' */ Public Function toNext(Optional ByRef oKey, Optional ByRef oValue) As Boolean On Error GoTo Err_Handler ref oValue, value(pPos + 1) oKey = key toNext = Not EOF Exit_Handler: Exit Function Err_Handler:: handleError Err, "toNext" Resume Exit_Handler Resume End Function '/** ' * Analog zu toNext(). Gibt jedich ein ListStream zurück bei dem der Zeiger auf der neuen Position ist ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @param (out) Boolean Information, ob der Prozess erfolgreich war ' * @return ListStream ' */ Public Function streamToNext(Optional ByRef oKey, Optional ByRef oValue, Optional oSuccessful As Boolean) As ListStream oSuccessful = toNext(oKey, oValue) Set streamToNext = setPos(oKey) End Function '/** ' * Eins Zurückrücken und Erfolg zurückgeben ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @return Boolean ' */ Public Function toPrev(Optional ByRef oKey, Optional ByRef oValue) As Boolean On Error GoTo Err_Handler ref oValue, value(pPos - 1) oKey = key toPrev = Not BOF Exit_Handler: Exit Function Err_Handler:: handleError Err, "toPrev" Resume Exit_Handler Resume End Function '/** ' * Analog zu toPrev(). Gibt jedich ein ListStream zurück bei dem der Zeiger auf der neuen Position ist ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @param (out) Boolean Information, ob der Prozess erfolgreich war ' * @return ListStream ' */ Public Function streamToPrev(Optional ByRef oKey, Optional ByRef oValue, Optional oSuccessful As Boolean) As ListStream oSuccessful = toPrev(oKey, oValue) Set streamToPrev = setPos(oKey) End Function '/** ' * Wert an einer bestimmten Position zurückgeben ' * @param Long Neue Position (default aktuelle Position) ' * @return Variant ' */ Public Property Get value(Optional ByVal iIndex& = -2) As Variant On Error GoTo Err_Handler If iIndex >= -1 Then pPos = iIndex If EOF Or BOF Then Exit Property Dim ks: ks = pList.keys ref value, pList(ks(pos)) Exit_Handler: Exit Property Err_Handler:: handleError Err, "value" Resume Exit_Handler Resume End Property '/** ' * Key an einer bestimmten Position zurückgeben ' * @param Variant Key a der neuen Position ' * @return Variant ' */ Public Property Get key(Optional ByVal iIndex& = -2) As Variant On Error GoTo Err_Handler If iIndex >= -1 Then pPos = iIndex If EOF Or BOF Then Exit Property x__getKey pPos, key Exit_Handler: Exit Property Err_Handler:: handleError Err, "value" Resume Exit_Handler Resume End Property '/** ' * Auf den ersten Eintrag gehen ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @return Boolean ' */ Public Function toFirst(Optional ByRef oKey, Optional ByRef oValue) As Boolean On Error GoTo Err_Handler ref oValue, value(0) oKey = key toFirst = Not BOF Exit_Handler: Exit Function Err_Handler:: handleError Err, "toFirst" Resume Exit_Handler Resume End Function '/** ' * Analog zu toFirst(). Gibt jedich ein ListStream zurück bei dem der Zeiger auf der neuen Position ist ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @param (out) Boolean Information, ob der Prozess erfolgreich war ' * @return ListStream ' */ Public Function streamToFirst(Optional ByRef oKey, Optional ByRef oValue, Optional oSuccessful As Boolean) As ListStream oSuccessful = toFirst(oKey, oValue) Set streamToFirst = setPos(oKey) End Function '/** ' * Auf den letzten Eintrag gehen ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @return Boolean ' */ Public Function toLast(Optional ByRef oKey, Optional ByRef oValue) As Boolean On Error GoTo Err_Handler ref oValue, value(count - 1) oKey = key toLast = Not EOF Exit_Handler: Exit Function Err_Handler:: handleError Err, "toLast" Resume Exit_Handler Resume End Function '/** ' * Analog zu toLast(). Gibt jedich ein ListStream zurück bei dem der Zeiger auf der neuen Position ist ' * @param (out) Variant Key a der neuen Position ' * @param (out) Variant Wert an der neuen Position ' * @param (out) Boolean Information, ob der Prozess erfolgreich war ' * @return ListStream ' */ Public Function streamToLast(Optional ByRef oKey, Optional ByRef oValue, Optional oSuccessful As Boolean) As ListStream oSuccessful = toLast(oKey, oValue) Set streamToLast = setPos(oKey) End Function Public Property Get pos&(): If pPos < 0 Then pPos = 0 If pPos > count - 1 Then pPos = count - 1 pos = pPos End Property Public Property Let pos(ByVal iPos&): pPos = iPos: End Property Public Sub resetPos() pPos = -1 End Sub '/** ' * Auf einen Bestimmten Datensatz setzn ' * @param Long Neue Position ' * @return ListStream ' */ Public Function setPos(ByVal iPos) As ListStream On Error GoTo Err_Handler Set setPos = x__newLS(pList) Dim p If x__getIndex(iPos, p) Then setPos.pos = p Exit_Handler: Exit Function Err_Handler:: handleError Err, "setPos" Resume Exit_Handler Resume End Function '/** ' * Grösster Wert ' * @return Variant ' */ Public Function max() As Variant On Error GoTo Err_Handler max = greatestA(pList.items) Exit_Handler: Exit Function Err_Handler:: handleError Err, "max" Resume Exit_Handler Resume End Function Public Function kMax() As Variant kMax = keys.max End Function '/** ' * Kleinster Wert ' * @return Variant ' */ Public Function min() As Variant On Error GoTo Err_Handler min = leastA(pList.items) Exit_Handler: Exit Function Err_Handler:: handleError Err, "min" Resume Exit_Handler Resume End Function Public Function kMin() As Variant kMin = keys.min End Function '/** ' * Gibt den Wert an einer bestimmten Position zurück. ' * @param Variant Key oder Index ' * @param enuIndexOrKey Angabe ob es sich um einen Key handelt, sollte der erste param numrisch sein ' * @param Variant Der passende Key wird als Referenz zurückgegeben ' * @return Variant ' */ Public Function getItem( _ ByVal iIndex As Variant, _ Optional ByVal iIndexOrKey As enuIndexOrKey = ikKey, _ Optional ByRef oKey _ ) As Variant On Error GoTo Err_Handler oKey = getKey(iIndex, iIndexOrKey) ref getItem, pList(oKey) Exit_Handler: Exit Function Err_Handler: handleError Err, "getItem", iIndex, iIndexOrKey Resume Exit_Handler Resume End Function '/** ' * Gibt den Key an einer bestimmten Position zurück. ' * @param Variant Key oder Index ' * @param enuIndexOrKey Angabe ob es isch um einen Key handelt, sollte der erste param numrisch sein ' * @return Variant ' */ Public Function getKey( _ Optional ByRef iIndex As Variant = 0, _ Optional ByVal iIndexOrKey As enuIndexOrKey = ikIndex _ ) As Variant On Error GoTo Err_Handler If iIndexOrKey = ikIndex And Not IsNumeric(iIndex) Then Err.Raise 13 Dim ks: ks = pList.keys getKey = iIndex If pWithKeys And iIndexOrKey = ikIndex Then getKey = ks(iIndex) Exit_Handler: Exit Function Err_Handler: handleError Err, "getItem", iIndex, iIndexOrKey Resume Exit_Handler Resume End Function '/** ' * Gibt den Wert eines speziellen Keys zurück ' * @param enuGetItemSpecialType ' * @param Variant Der passende Key wird als Referenz zurückgegeben ' * @return Variant Wert ' */ Public Function getItemSpecial(ByVal iBy As enuGetItemSpecialType, Optional ByRef oKey As Variant) As Variant If pList.count = 0 Then Exit Function oKey = getKeySpecial(iBy) ref getItemSpecial, pList(oKey) End Function '/** ' * Gibt einen speziellen Key ' * @param enuGetItemSpecialType ' * @return Variant Key ' */ Public Function getKeySpecial(ByVal iBy As enuGetItemSpecialType) As Variant If pList.count = 0 Then Exit Function Dim ks: ks = pList.keys Select Case iBy Case byMaxKey: getKeySpecial = kMax Case byMinKey: getKeySpecial = kMin Case byFirst: getKeySpecial = ks(LBound(ks)) Case byLast: getKeySpecial = ks(UBound(ks)) End Select End Function Public Function getRand(Optional ByVal iSize As Long = 1, Optional iGet As enuWorkWith = wwValue) As Variant If iSize < 1 Then iSize = 1 If iSize > count Then iSize = count 'Int((upperbound - lowerbound + 1) * Rnd + lowerbound) Dim idx& Dim arr() ReDim arr(0 To iSize - 1) Dim i%: For i = 0 To UBound(arr) idx = Int(Me.count * Rnd + 1) - 1 Select Case iGet Case wwIndex: arr(i) = idx Case wwKey: arr(i) = getKey(idx, ikIndex) Case wwValue: arr(i) = getItem(idx, ikIndex) End Select Next ref getRand, IIf(iSize = 1, arr(0), arr) End Function Public Function kGetRand(Optional ByVal iSize As Long = 1) As Variant ref kGetRand, getRand(iSize, wwKey) End Function Public Function vGetRand(Optional ByVal iSize As Long = 1) As Variant ref vGetRand, getRand(iSize, wwValue) End Function '/** ' * Erstellt aus der Liste einen String mittels JSF (Platzhalter sind die Keys der Liste) ' * @example ?ListSTream("{name:'Yaslaw',alter:45}").parseToString("#{name} ist #{alter} alt") -> 'Yaslaw ist 45 alt' ' * @param String JSF-String ' * @return String ' */ #If JSF Then Public Function parseToString(ByVal iStringExpr As String, Optional ByVal iJsfParams As jsfParams = jsfParams.[_NA]) As String parseToString = JSF(pList).parse(iStringExpr, iJsfParams) End Function #End If '/** ' * Erstellt aus der List einen JSON-String ' * @param enuListType Art der Liste ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String 260 = jqmNoUnicode + jqmSingleQuote ' * @return String ' */ Public Function toJSON(Optional iListType As enuListType = ltDictionary, Optional ByVal iEncodeParams As Long = 260) As String On Error GoTo Err_Handler If pList Is Nothing Then toJSON = Empty Else toJSON = Application.Run("obj2json", collect(iListType), iEncodeParams) End If GoTo Exit_Handler alter: toJSON = "lib_json ist nicht installiert" Exit_Handler: Exit Function Err_Handler: If Err.Number = 2517 Then Resume alter handleError Err, "toJSON", iListType, iEncodeParams Resume Exit_Handler Resume End Function '/** ' * Gibt den Inhalt der Liste in einer Lesbarer Form aus ' * @example ? ListStream(array("a","x","m")).sort.dump() -> {0 => a, 2 => m, 1 => x} ' * @return String ' */ Public Function dump(Optional ByVal iDelimiter As String = ", ") As String Dim isRef As Boolean: isRef = pByRef pByRef = False dump = "{" & mapParse("#{key} => #{value}").join(iDelimiter) & "}" pByRef = isRef End Function '------------------------------------------------------------------------------- ' -- Private Methodes '------------------------------------------------------------------------------- '/** ' * Erstellt einen Clone der Settings und übernimmt die neue Liste ' * @param Variant ' * @param vbCompareMethod ' * @return ListStream ' */ Private Function x__newLS(ByRef iList As Variant, Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) As ListStream If pByRef Then Set pList = iList recalcForEachCollection CompareMode = x__nCM(iCompareMode, CompareMode) Set x__newLS = Me Exit Function End If Set x__newLS = ListStream(iList, x__nCM(iCompareMode)).x__setInternalProperties(pWithKeys) x__newLS.pos = pPos 'x__newLS.recalcForEachCollection End Function '/** ' * Erstellt ein Clone eines Dictionary ' * @param CompareMethode ' * @param Dictionary Wenn kein Dictionary gesetzt ' * @return Dictionary ' */ Private Function x__cloneDict(Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, Optional ByRef iDict As Object = Nothing) As Object If pByRef Then Set x__cloneDict = IIf(iDict Is Nothing, pList, iDict) x__cloneDict.CompareMode = x__nCM(iCompareMode, CompareMode) Exit Function End If Set x__cloneDict = x__createDict(iCompareMode) Dim src As Object: Set src = IIf(iDict Is Nothing, pList, iDict) Dim k: For Each k In src.keys x__cloneDict.add k, src(k) Next End Function '/** ' * Diese Methode muss leider Public sein, sollte aber nicht verwednet werden ' * @param Boolean ' * @param Long ' * @return ListStream ' */ Public Function x__setInternalProperties(ByVal iHaveKeys As Boolean) As ListStream pWithKeys = iHaveKeys Set x__setInternalProperties = Me End Function '/** ' * Erstellt ein neues Dictionary mit dem compareMode der Liste oder einem Neuen ' * @param CompareMode ' * @return Dictionary ' */ Private Function x__createDict(Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) As Object Set x__createDict = CreateObject("scripting.Dictionary") x__createDict.CompareMode = x__nCM(iCompareMode) End Function Public Function x__compaireItems( _ ByRef iItem1, _ ByRef iItem2, _ Optional ByVal iTypeSensitive As Boolean = False, _ Optional ByVal iCompareType As enuCompaireType = ctBoth, _ Optional ByVal iJsonToList As Boolean = False, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As Boolean x__compaireItems = False Dim cm As VbCompareMethod: cm = IIf(iCompareMode = C_NOT_DEFINED, CompareMode, iCompareMode) 'Nur einer von Beiden ist Nix -> false If isNothing(iItem1) <> isNothing(iItem2) Then Exit Function 'Beide sind nix und der Typenvergleich ist unwichtig -> true If isNothing(iItem1) And isNothing(iItem2) And Not iTypeSensitive Then x__compaireItems = True: Exit Function 'Eines ist ein Objekt, das andere nicht -> false If IsObject(iItem1) <> IsObject(iItem2) Then Exit Function 'Verschiedene Typen -> false If iTypeSensitive And TypeName(iItem1) <> TypeName(iItem2) Then Exit Function 'String vor isList auswerten, da keine If Not iJsonToList And (varType(iItem1) = vbString Or varType(iItem2) = vbString) Then x__compaireItems = x__compaireValue(iItem1, iItem2, iTypeSensitive, iCompareMode) Exit Function End If 'Listen If x__isList(iItem1) And x__isList(iItem2) Then Dim dict1 As Object: Set dict1 = x__toDict(iItem1) Dim dict2 As Object: Set dict2 = x__toDict(iItem2) 'Unterschiedliche Grössen -> false If dict1.count <> dict2.count Then Exit Function Dim keys1: keys1 = dict1.keys Dim keys2: keys2 = dict2.keys Dim i&: For i = 0 To UBound(keys1) If andB(iCompareType, ctKey) Then If Not x__compaireValue(keys1(i), keys2(i), iTypeSensitive, iCompareMode) Then Exit Function End If If andB(iCompareType, ctValue) Then If Not x__compaireItems(dict1(keys1(i)), dict2(keys2(i)), iTypeSensitive, iCompareType, iJsonToList, iCompareMode) Then Exit Function End If Next x__compaireItems = True ElseIf IsObject(iItem1) Then '//TODO '//vergleicht ob es von dersleben Refernez ist. Ist leider kein Property-Vergleich x__compaireItems = iItem1 Is iItem2 Else x__compaireItems = x__compaireValue(iItem1, iItem2, iTypeSensitive, iCompareMode) End If End Function Public Function x__compaireValue( _ ByRef iValue1, _ ByRef iValue2, _ Optional ByVal iTypeSensitive As Boolean = False, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED _ ) As Boolean x__compaireValue = False If iTypeSensitive Then If iTypeSensitive And TypeName(iValue1) <> TypeName(iValue2) Then Exit Function x__compaireValue = iValue1 = iValue2 Else Dim s1: s1 = var2CodeStr(iValue1, , sqlOnErrorReturnError + sqlStringNoQutes + sqlNullToEmpty) Dim s2: s2 = var2CodeStr(iValue2, , sqlOnErrorReturnError + sqlStringNoQutes + sqlNullToEmpty) x__compaireValue = s1 = s2 End If End Function '/** ' * Wandelt alle möglichen Listen in ein Dictionary ' * Dictionary/Collection/ListStream/Iterator/Recordset/Array/String(Json/Single Value) ' * @param Variant ' * @param CompareMode ' * @param Boolean (out) Info ob das Dictionary Keys beinhaltet oder nur Indexe ' * @return Object ' */ Public Function x__toDict( _ Optional ByRef iList As Variant = Nothing, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByRef oWithKeys As Boolean = False, _ Optional ByVal iNothingAsObjList = False, _ Optional ByVal iNoList2List As Boolean = True _ ) As Object On Error GoTo Err_Handler Dim i& oWithKeys = False Set x__toDict = x__createDict(iCompareMode) If IsObject(iList) Then Select Case TypeName(iList) Case "Nothing": If iNothingAsObjList Then Set x__toDict = pList Case "Dictionary" oWithKeys = True Set x__toDict = iList Case "Collection" oWithKeys = True Dim keys() As String: keys = getCollectionKeys(iList) For i = 1 To iList.count x__toDict.add keys(i), iList(i) Next i Case "ListStream": Set x__toDict = x__cloneDict(iCompareMode, iList.list) Case "Iterator": Set x__toDict = x__cloneDict(iCompareMode, iList.source2Dict) Case "JSF": Set x__toDict = x__cloneDict(iCompareMode, iList.map) Case "Worksheet": Set x__toDict = x__toDict(iList.UsedRange, iCompareMode, oWithKeys, iNothingAsObjList, iNoList2List) Case "Range": Set x__toDict = x__toDictFromRange(iList, , , iCompareMode) Case "IMatchCollection2": Dim j&: For j = 0 To iList.count - 1 x__toDict.add j, x__toDict(iList(j).subMatches) Next j Case "IMatch2": Set x__toDict = x__toDict(iList.subMatches) Case "ISubMatches": Dim k&: For k = 0 To iList.count - 1 x__toDict.add k, iList(k) Next k Case "Queue": For k = 0 To iList.count - 1 x__toDict.add k, iList.Dequeue() Next k Case "Stack": For k = iList.count - 1 To 0 Step -1 x__toDict.add k, iList.pop() Next k Case "ArrayList" For k = 0 To iList.count - 1 x__toDict.add k, iList.item(k) Next k Case "Recordset2", "Recordset": If iList.RecordCount = 0 Then Exit Function iList.MoveFirst Do While Not iList.EOF Dim rd As Object: Set rd = x__createDict(iCompareMode) Dim fld As Object: For Each fld In iList.fields rd.add fld.name, fld.value Next x__toDict.add inc(i), rd iList.MoveNext Loop Case "Fields" For k = 0 To iList.count - 1 x__toDict.add iList(k).name, iList(k) Next k Case Else: x__toDict.add iList, 0 End Select ElseIf IsArray(iList) Then For i = LBound(iList) To UBound(iList) x__toDict.add i, iList(i) Next ElseIf varType(iList) = vbString Then Set x__toDict = x__toDictFromString(iList, iCompareMode, oWithKeys, iNoList2List) ElseIf iNoList2List And (varType(iList) = vbEmpty Or varType(iList) = vbNull) Then 'leerer Dict zurückgeben ElseIf iNoList2List Then x__toDict.add 0, iList ElseIf varType(iList) = vbEmpty Or varType(iList) = vbNull Then Else Err.Raise 13 End If Exit_Handler: Exit Function Err_Handler:: handleError Err, "x__toDict", iList, iCompareMode Resume Exit_Handler Resume End Function Public Function x__isList( _ ByRef iList, _ Optional ByVal iNoList2List As Boolean = False _ ) As Boolean x__isList = True If IsObject(iList) Then Select Case TypeName(iList) Case _ "Dictionary", _ "Collection", _ "ListStream", _ "Iterator", _ "JSF", _ "Worksheet", _ "Range", _ "IMatchCollection2", _ "IMatch2", _ "ISubMatches", _ "Queue", _ "Stack", _ "ArrayList", _ "Recordset2", _ "Fields" Exit Function End Select ElseIf IsArray(iList) Then Exit Function ElseIf varType(iList) = vbString Then Dim dict As Variant: ref dict, x__toDictFromString(iList, , , iNoList2List) If isEmpty(dict) Then x__isList = False Exit Function Else If dict.count > 0 Then Exit Function End If ElseIf varType(iList) = vbEmpty Or varType(iList) = vbNull Then Exit Function End If x__isList = False End Function Private Function x__toDictFromRange(ByRef iRange As Variant, Optional ByVal iWithHeader As Boolean = True, Optional ByVal iKeyCol = -1, Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED) If TypeName(iRange) = "Worksheet" Then Set iRange = iRange.UsedRange If Not TypeName(iRange) = "Range" Then Exit Function Set x__toDictFromRange = x__createDict(iCompareMode) Dim header As Object: Set header = x__createDict(vbTextCompare) Dim colNr&: For colNr = 1 To iRange.Columns.count Dim v$: v = "F" & colNr If iWithHeader Then If Not header.exists(iRange.Cells(1, colNr).value) Then v = iRange.Cells(1, colNr).value End If header.add colNr, v Next colNr Dim rowNr&: For rowNr = IIf(iWithHeader, 2, 1) To iRange.rows.count Dim node: Set node = x__createDict(iCompareMode) For colNr = 1 To iRange.Columns.count node.add header(colNr), iRange.Cells(rowNr, colNr).value Next colNr Dim k: k = rowNr - 1 If Not iKeyCol = -1 Then k = node(iKeyCol) x__toDictFromRange.add k, node Next rowNr End Function '/** ' * SpezialfallErstellt aus einem String ein Dictionary. ' * Ist JSON lib_json installiert, dann können JSON-Strings geparst werden. ' * Ansonsten wird einfach ein Dictionary erstellt und der String als Einzeleintrag ' * @param String ' * @param vbCompareMethod ' * @return Dict ' */ Private Function x__toDictFromString( _ ByVal iJson As String, _ Optional ByVal iCompareMode As VbCompareMethod = C_NOT_DEFINED, _ Optional ByRef oWithKeys As Boolean = False, _ Optional ByVal iNoList2List As Boolean = False _ ) As Variant Dim runAlter As Boolean On Error GoTo Err_Handler '72 = jrtSingle2List(64) + jrtDictionary(8) + jrtEmptyList(32) Dim jsonDecodeParam&: jsonDecodeParam = 8 + IIf(iNoList2List, 64 + 32, 0) ' Dim dict As Variant: ref dict, Application.run("json2obj", iJson, , , x__nCM(iCompareMode)) ' If isEmpty(dict) And iNoList2List Then dict = Array(iJson) ' Set x__toDictFromString = x__toDict(dict, iCompareMode, oWithKeys, , False) ref x__toDictFromString, Application.Run("json2obj", iJson, jsonDecodeParam, , x__nCM(iCompareMode)) oWithKeys = x__keysExists(x__toDictFromString) GoTo Exit_Handler alter: Set x__toDictFromString = x__createDict(iCompareMode) If iNoList2List Then x__toDictFromString.add 0, iJson Exit_Handler: Exit Function Err_Handler: If Err.Number = 2517 And Not runAlter Then Resume alter handleError Err, "x__toDictFromString", iJson, iCompareMode Resume Exit_Handler Resume End Function '/** ' * Herausfinden, ob das Dictionary Keys hat. ' */ Public Function x__keysExists(Optional ByRef iDict As Variant = Nothing) As Boolean If iDict Is Nothing Then Set iDict = pList x__keysExists = True Dim keys(): keys = iDict.keys Dim i&: For i = 0 To iDict.count - 1 If Not keys(i) = i Then Exit Function Next i x__keysExists = False End Function '/** ' * Handelt den Default CompaireMethod ' * @param vbCompareMethod ' * @param vbCompareMethod ' * @return vbCompareMethod ' */ Private Function x__nCM(ByVal iCompareMode As VbCompareMethod, Optional ByVal iDefault As VbCompareMethod = C_NOT_DEFINED) As VbCompareMethod If iDefault = C_NOT_DEFINED Then iDefault = CompareMode x__nCM = IIf(iCompareMode = C_NOT_DEFINED, iDefault, iCompareMode) End Function '/** ' * Sucht den Key aus einem Dictionary ' * @param Variant Index oder Key der List ' * @param (out) Variant Key ' * @param Dictionary ' * @return Boolean ' */ Private Function x__getKey(ByVal iIndex, Optional ByRef oKey = Null, Optional ByRef iDict As Object = Nothing) As Boolean x__getKey = False oKey = Null Dim dict As Object: Set dict = IIf(iDict Is Nothing, pList, iDict) If IsNumeric(iIndex) Then If CLng(iIndex) < 0 Or CLng(iIndex) >= dict.count Then Exit Function Dim ks: ks = dict.keys oKey = ks(CLng(iIndex)) x__getKey = True ElseIf dict.exists(iIndex) Then oKey = iIndex x__getKey = True End If End Function Private Function x__getIndex(ByVal iIndex, Optional ByRef oIndex = Null, Optional ByRef iDict As Object = Nothing) As Boolean x__getIndex = False oIndex = Null Dim dict As Object: Set dict = IIf(iDict Is Nothing, pList, iDict) If IsNumeric(iIndex) Then oIndex = iIndex x__getIndex = True ElseIf dict.exists(iIndex) Then Dim ks: ks = dict.keys Dim i&: For i = 0 To UBound(ks) - 1 If ks(i) = iIndex Then Exit For Next i oIndex = i x__getIndex = True End If End Function '/** ' * Castet ein Value ' * @param Variant ' * @param vbVarType ' * @return Variant '*/ Private Function x__castValue(ByRef iItem As Variant, Optional ByVal iVarType As VbVarType = vbString) As Variant Const C_ecOnErrorDefault = 1 Dim runAlter As Boolean On Error GoTo Err_Handler 'Spezialfälle abfangen Select Case TypeName(iItem) Case "DateTime": ref x__castValue, x__castValue(iItem.dateValue, iVarType): GoTo Exit_Handler End Select 'Versuchen on die Funktion cast_cast.cast installiert ist On Error Resume Next x__castValue = Application.Run("cast", iVarType, iItem, C_ecOnErrorDefault) If Err.Number = 0 Then GoTo Exit_Handler Err.clear On Error GoTo Err_Handler alter: runAlter = True Select Case iVarType Case vbVariant: ref x__castValue, iItem '12 1 zu 1 übernehmen Case vbInteger: x__castValue = CInt(NZ(iItem)) '2 Case vbLong: x__castValue = CLng(NZ(iItem)) '3 Case vbSingle: x__castValue = CSng(NZ(iItem)) '4 Case vbDouble: x__castValue = CDbl(NZ(iItem)) '5 Case vbCurrency: x__castValue = CCur(NZ(iItem)) '6 Case vbDate: x__castValue = CDate(NZ(iItem)) '7 Case vbString: x__castValue = CStr(NZ(iItem)) '7 Case vbBoolean: x__castValue = CBool(NZ(iItem)) '11 Case vbVariant: ref x__castValue, CVar(iItem) Case vbDecimal: x__castValue = CDec(NZ(iItem)) '14 Case vbByte: x__castValue = CByte(NZ(iItem)) '17 Case Else: ref x__castValue, iItem End Select Exit_Handler: Exit Function Err_Handler: If Err.Number = 2517 And Not runAlter Then Resume alter 'If iOnErrorRaise Then Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext x__castValue = "#Error: TypeMissmatch" End Function '/** ' * Parst ein String mit Platzhaltern ' */ Private Function x__nodeToString( _ ByVal iStringExpr As String, _ ByRef iKey As Variant, _ ByRef iValue As Variant, _ ByVal iIndex As Variant, _ Optional ByVal iVarType As VbVarType = C_NOT_DEFINED, _ Optional ByVal iAsSqlString As Boolean = True, _ Optional ByVal iJsfParse As Boolean = True _ ) As String On Error GoTo Err_Handler Dim value: value = Switch(IsObject(iValue), "#" & TypeName(iValue), IsArray(iValue), "#Array", True, iValue) Dim v As Variant, k As Variant If iAsSqlString Then Dim vt As VbVarType: vt = IIf(iVarType = C_NOT_DEFINED, varType(value), iVarType) If IsNull(value) Then vt = vbNull v = var2CodeStr(value, vt) k = var2CodeStr(iKey) Else v = NZ(value, "NULL") k = iKey End If #If JSF Then If iJsfParse Then Dim dict As Object: Set dict = x__createDict dict.add "item", v dict.add "value", v dict.add "val", v dict.add "key", k dict.add "index", iIndex dict.add "id", iIndex dict.add "pos", iIndex dict.add "idx", iIndex x__nodeToString = JSF(dict).parse(iStringExpr) GoTo Exit_Handler End If #End If x__nodeToString = iStringExpr x__nodeToString = rxItem.replace(x__nodeToString, v) x__nodeToString = rxKey.replace(x__nodeToString, k) x__nodeToString = rxIndex.replace(x__nodeToString, iIndex) Exit_Handler: Exit Function Err_Handler:: handleError Err, "x__nodeToString", iStringExpr, iKey, iValue, iIndex, iVarType, iAsSqlString, iJsfParse Resume Exit_Handler Resume End Function '/** ' * Erstetzt für call-Funktionen die Patterns in den Args durch die Werte ' * @param ListSTream ' * @param Array ' * @return Array ' */ Private Function x__replaceArgs( _ ByRef iKey As Variant, _ ByRef iValue As Variant, _ ByVal iIndex As Variant, _ ByRef iArgs() As Variant _ ) As Variant() Dim args() As Variant: args = iArgs If Not isArrayValid(iArgs) Then Exit Function Dim i&: For i = LBound(iArgs) To UBound(iArgs) If varType(iArgs(i)) = vbString Then If rxItemOnly.test(iArgs(i)) Then ref args(i), iValue: GoTo NXT If rxKeyOnly.test(iArgs(i)) Then ref args(i), iKey: GoTo NXT If rxIndexOnly.test(iArgs(i)) Then ref args(i), iIndex: GoTo NXT End If NXT: Next i x__replaceArgs = args End Function '------------------------------------------------------------------------------- ' -- Private RegEx Properties '------------------------------------------------------------------------------- ' /** ' * Item ' * 1->grp, 2->Attribut, 3->' oder ", 4->Value ' */ Private Property Get rxItem() As Object 'Static rx As Object: If rx Is Nothing Then Set rx = cRx("/#\{(?:item|value|val)(?:[ _-]*([12]))?(?:\|(\w+)=(['""]{1,2})([^\3\}]+)\3)?\}/gi") Static rx As Object: If rx Is Nothing Then Set rx = cRx("/#\{(?:item|value|val)(?:[ _-]*([12]))?\}/gi") Set rxItem = rx End Property ' /** ' * Key ' */ Private Property Get rxKey() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/#\{key(?:[ _-]*([12]))?\}/gi") Set rxKey = rx End Property ' /** ' * Index ' */ Private Property Get rxIndex() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/#\{(?:index|id|pos|idx)(?:[ _-]*([12]))?\}/gi") Set rxIndex = rx End Property ' /** ' * Ganzer String ist nur das Item ' */ Private Property Get rxItemOnly() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^#\{(object|ref|value|item)\}$/gi") Set rxItemOnly = rx End Property ' /** ' * Ganzer String ist nur der Key ' */ Private Property Get rxKeyOnly() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^#\{(key)\}$/gi") Set rxKeyOnly = rx End Property ' /** ' * Ganzer String ist nur der Index ' */ Private Property Get rxIndexOnly() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^#\{(?:index|id|pos|idx)\}$/gi") Set rxIndexOnly = rx End Property '------------------------------------------------------------------------------- ' -- Libraries ' zusammenkopierte Methoden, die verwendet werden '------------------------------------------------------------------------------- '/** ' * Erstellt einen leeren Array. ' * @param VbVarType ' * @return Array ' */ Private Function emptyArray(Optional ByVal iVarType As VbVarType = vbVariant, Optional ByVal iUcase As Long = C_NOT_DEFINED) As Variant Dim retArr As Variant Select Case iVarType Case vbDate: retArr = z__emptyArrayDate Case vbString: retArr = z__emptyArrayString Case vbInteger: retArr = z__emptyArrayInteger Case vbLong: retArr = z__emptyArrayLong Case vbDouble: retArr = z__emptyArrayDouble Case vbBoolean: retArr = z__emptyArrayBoolean Case vbObject: retArr = z__emptyArrayObject '//TODO: weitere Datentypen abhandeln Case Else: retArr = z__emptyArrayVariant End Select If iUcase > C_NOT_DEFINED Then ReDim retArr(0 To iUcase) emptyArray = retArr End Function '/** ' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht. ' * @link https://wiki.yaslaw.info/doku.php/vba/functions/ref ' * @version 1.2.0 ' * @param Variant Variable, die den Wert bekommen soll ' * @param Variant Return Wert selber ' */ Private Sub ref(target, result) If VBA.IsObject(result) Then Set target = result Else target = result End Sub '/** ' * Analog zu callByName, nimmt aber auch ein Argument-Array anstelle des ParamArray an. ' * @link https://stackoverflow.com/a/36316527 Private Function callByNameA(Object As Object, ProcName As String, callType As VbCallType, args() As Variant) If isArrayValid(args) Then ref callByNameA, rtcCallByName(Object, StrPtr(ProcName), callType, args) Else ref callByNameA, CallByName(Object, ProcName, callType) End If End Function '/** ' * Führt eine UserDefinedFunction aus. Im Gegensatz zu Application.run werden die Parameter in einem Array übergeben ' * @param String Name der UserDefinedFunction ' * @param Array Die Argumente zur Funktion ' * @return Variant Rückgabewert der Funktion ' */ Private Function callUdfByArray(ByVal iMethodName As String, ByRef iArgs As Variant) As Variant If Not isArrayValid(iArgs) Then ref callUdfByArray, Application.Run(iMethodName) Exit Function End If Dim diff As Integer: diff = LBound(iArgs) Select Case UBound(iArgs) - diff Case -1: ref callUdfByArray, Application.Run(iMethodName) Case 0: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff)) Case 1: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff)) Case 2: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff), iArgs(2 + diff)) Case 3: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff), iArgs(2 + diff), iArgs(3 + diff)) Case 4: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff), iArgs(2 + diff), iArgs(3 + diff), iArgs(4 + diff)) Case 5: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff), iArgs(2 + diff), iArgs(3 + diff), iArgs(4 + diff), iArgs(5 + diff)) Case 6: ref callUdfByArray, Application.Run(iMethodName, iArgs(diff), iArgs(1 + diff), iArgs(2 + diff), iArgs(3 + diff), iArgs(4 + diff), iArgs(5 + diff), iArgs(6 + diff)) 'TODO: Aufruf mit weiteren Parametern ermöglichen Case Else: Err.Raise 450 'Wrong number of arguments or invalid property assignment End Select End Function '/** ' * Prüft ob es ein gültiger Array ist ' * @param Variant ' * @return Boolean ' */ Private Function isArrayValid(ByRef iArray As Variant) As Boolean On Error Resume Next Dim dummy As Long: dummy = UBound(iArray) isArrayValid = Err.Number = 0 End Function '/** ' * @link http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version ' * @version 2.1.0 (01.12.2014) ' * @example myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase ' * @param String Pattern mit Delimiter und Modifier analog zu PHP ' * @return Object RegExp-Object ' */ Private Function cRx(ByVal iPattern$) As Object Static rxP As Object: Set cRx = CreateObject("VBScript.RegExp") If rxP Is Nothing Then: Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" Dim sm As Object: Set sm = rxP.execute(iPattern)(0).subMatches cRx.pattern = sm(1): cRx.IgnoreCase = Not VBA.isEmpty(sm(2)): cRx.Global = Not VBA.isEmpty(sm(3)): cRx.Multiline = Not VBA.isEmpty(sm(4)) End Function '/** ' * Prüft, ob eine Variable Null, Empty, Nothing, Leerstring, leerer Array etc ist ' * @link https://wiki.yaslaw.info/doku.php/vba/functions/isnothing ' * @version 1.0.3 ' * @example boolean = isNothing(object) ' * @example 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(VBA.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 If UBound(iValue) = -1 Then Exit Function End If If IsMissing(iValue) Then Exit Function End Select isNothing = False End Function '/** ' * trim \s: Entfernt im Gegensatz zu trim() auch Zeilenumbrüche, Tabulatoren etc. Alles was regexp \s ist ' * @link https://wiki.yaslaw.info/doku.php/vba/functions/trims ' * @version 1.1.1 ' * @example string = trims(string [,direction][,clearCache]) ' * @param String ' * @param trDirection Angabe, auf welcher Seite getrimmt werden soll ' * @return String ' */ Private Property Get rxTrim(Optional ByVal iTrimType As enuTrimType = ttTrim) As Object Const C_PATTERN = "^[\s\u0000]*([\S\s]*\b)?[\s\u0000]*$" Const C_L_PATTERN = "^[\s\u0000]*([\S\s\u0000]*)?$" Const C_R_PATTERN = "^([\S\s\u0000]*\b)?[\s\u0000]*$" Static cacheRxTrim(1 To 3) As Object If cacheRxTrim(iTrimType) Is Nothing Then Set cacheRxTrim(iTrimType) = CreateObject("VBScript.RegExp") cacheRxTrim(iTrimType).pattern = Choose(iTrimType, C_L_PATTERN, C_R_PATTERN, C_PATTERN) End If Set rxTrim = cacheRxTrim(iTrimType) End Property '/** ' * @link Abwandlung von https:://wiki.yaslaw.info/doku.php/vba/cast/ctosqlstr ' * @version 1.2.1 ' * Gibt den Value in VBA-Code Form zurück. Kann für Evals etc. benutzt werden ' * @param Variant Wert oder Array von Werten ' * @param vbVarType ' * @param enuSqlParams Steuerparameters ' * @param Variant Wert, falls iItem Null ist und sqlNullToEmpty nicht gesetzt ist ' * @return String Formatierter Wert oder eine Liste mit den Formatierten Werten ' */ Public Static Function var2CodeStr( _ Optional ByVal iItem As Variant = Null, _ Optional ByVal iVarType As VbVarType = vbVariant, _ Optional ByVal iCodeParams As enuSqlParams = enuSqlParams.[_Default], _ Optional ByVal iNullDefault As Variant = Null _ ) As String 'Spezialfall. Der String wird nicht geparst On Error GoTo Err_Handler 'Liste Auswerten If IsArray(iItem) Then Dim ret(): ReDim ret(LBound(iItem) To UBound(iItem)) Dim i&: For i = LBound(iItem) To UBound(iItem) ret(i) = var2CodeStr(iItem(i), iVarType, iCodeParams, iNullDefault) Next i var2CodeStr = VBA.join(ret, ", ") Exit Function End If 'Spezialfall NULL If IsNull(iItem) Then If Not IsNull(iNullDefault) Then iItem = iNullDefault ElseIf andB(iCodeParams, sqlIsNullable) Then var2CodeStr = "NULL" Exit Function ElseIf andB(iCodeParams, sqlNullToEmpty) Then iItem = Empty End If End If If iVarType = vbVariant Then If IsNumeric(iItem) Then iVarType = vbDouble ElseIf IsDate(iItem) Then iVarType = vbDate Else iVarType = varType(iItem) End If End If 'Einzelwert formatieren Select Case iVarType Case C_NOT_CASTEBLE 'Case C_NOT_DEFINED: var2CodeStr = var2CodeStr(z__vbType2dbType(varType(iItem)), iItem, iCodeParams, iNullDefault) 'Bei spezifizierten Nummern, zuerst zur Sicherheit konvertieren um zu prüfen ob die Zahl in das Format passt Case vbDecimal: var2CodeStr = VBA.trim(str(CDec(iItem))) Case vbLong: var2CodeStr = VBA.trim(str(CLng(iItem))) Case vbInteger: var2CodeStr = VBA.trim(str(CInt(iItem))) Case vbByte: var2CodeStr = VBA.trim(str(CByte(iItem))) Case vbCurrency: var2CodeStr = VBA.trim(str(CCur(iItem))) Case vbDouble: var2CodeStr = VBA.trim(str(CDbl(iItem))) Case vbSingle: var2CodeStr = VBA.trim(str(CSng(iItem))) Case vbBoolean: var2CodeStr = UCase((CBool(iItem))) 'Case vbDate: var2CodeStr = format(CDate(iItem), "\#mm\/dd\/yyyy\#") Case vbDate: Dim f As String: f = "\#mm\/dd\/yyyy hh:nn:ss\#" 'Datum und Zeit If (Abs(CDbl(iItem)) < 1) Then f = "\#hh:nn:ss\#" 'Nur Zeit If Int(CDbl(iItem)) = CDbl(iItem) Then f = "\#mm\/dd\/yyyy\#" 'Nur Datum var2CodeStr = format(CDate(iItem), f) Case Else: 'Strings und anderes Dim quote As String: quote = IIf(andB(iCodeParams, sqlStringDoubleQuotes), """", "'") If andB(iCodeParams, sqlStringNoQutes) Then quote = "" var2CodeStr = iItem If Not andB(iCodeParams, sqlStringNoMaskQuotes) Then var2CodeStr = replace(var2CodeStr, quote, quote & quote) var2CodeStr = quote & var2CodeStr & quote End Select Exit Function Err_Handler: If andB(iCodeParams, sqlOnErrorAssert) Then Debug.Print Err.Number, Err.Description Debug.Assert False End If If andB(iCodeParams, sqlOnErrorReturnError) Then Select Case Err.Number Case 6: var2CodeStr = "'#Overflow'" 'Overflow Case 13: var2CodeStr = "'#TypeMismatch'" 'Type Missmatch Case 438: var2CodeStr = "'#TypeMismatch'" 'Object doesn't support this property or method Case Else: var2CodeStr = "'#Err_" & Err.Number & "_" & Err.Description & "'" End Select Exit Function ElseIf andB(iCodeParams, sqlOnErrorReturnNull) Then var2CodeStr = "Null" Exit Function End If var2CodeStr = "'#Err " & Err.Number & " " & Err.Description & " '" End Function '/** ' * Macht einen Bit-Vergleich ' * @link http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb ' * @version 1.0.0 ' * @param Long ' * @param Long ' * @return Boolean ' */ Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean andB = ((iHaystack And iNeedle) = iNeedle) End Function '/** ' * Version 1.0.0 ' * Sortiert 2 Arrays anhand des ersten ' * @param Array Dieser Array wird sortiert ' * @param Array Dieser Array läuft mit ' */ Private Sub multiQuickSort(ioSortArr As Variant, Optional ioSecArr As Variant = Null) If IsNull(ioSecArr) Then ioSecArr = ioSortArr Dim delta&: delta = LBound(ioSortArr) - LBound(ioSecArr) x__multiQuickSort ioSortArr, ioSecArr, LBound(ioSortArr), least(UBound(ioSortArr), UBound(ioSecArr) + delta), delta End Sub 'Anpassung von https://stackoverflow.com/a/152325, so dass ein 2ter Array mitsortiert wird Private Sub x__multiQuickSort(ioSortArr As Variant, ioSecArr As Variant, inLow As Long, inHi As Long, Optional iDelta& = 0) Dim tmpLow&: tmpLow = inLow Dim tmpHi&: tmpHi = inHi Dim pivot: pivot = ioSortArr((inLow + inHi) \ 2) While (tmpLow <= tmpHi) While (ioSortArr(tmpLow) < pivot And tmpLow < inHi) tmpLow = tmpLow + 1 Wend While (pivot < ioSortArr(tmpHi) And tmpHi > inLow) tmpHi = tmpHi - 1 Wend If (tmpLow <= tmpHi) Then Dim tmpSwapArr: tmpSwapArr = ioSortArr(tmpLow) Dim tmpSwapSec: ref tmpSwapSec, ioSecArr(tmpLow - iDelta) ioSortArr(tmpLow) = ioSortArr(tmpHi) ref ioSecArr(tmpLow - iDelta), ioSecArr(tmpHi - iDelta) ioSortArr(tmpHi) = tmpSwapArr ref ioSecArr(tmpHi - iDelta), tmpSwapSec tmpLow = tmpLow + 1 tmpHi = tmpHi - 1 End If Wend If (inLow < tmpHi) Then x__multiQuickSort ioSortArr, ioSecArr, inLow, tmpHi, iDelta If (tmpLow < inHi) Then x__multiQuickSort ioSortArr, ioSecArr, tmpLow, inHi, iDelta End Sub '/** ' * Zählt die Variable per Referenz eins hoch und gibt den Wert zusätlich zurück ' * @param Number ' * @return Number ' */ Private Function inc(ByRef i As Variant) As Variant i = i + 1: inc = i End Function '/** ' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück ' * @version 1.1.0 ' * @param Keine Objekte ' * @return Grösster Wert ' * @example least("Hallo Welt", 42, "Mister-X") -> 42 '*/ Private Function least(ParamArray iItems() As Variant) As Variant least = iItems(LBound(iItems)) Dim item As Variant: For Each item In iItems If NZ(item) < NZ(least) Then least = item Next item End Function '/** ' * Version : 1.0.0 ' * Umkehrfunction zu xlsColLetter: Berchent aus einem String-Colmnidex die Position ' * ' * spaltennummer = xlsColNumber(spaltencode) ' * ' * @param String ' * @retrun Long '*/ Private Function xlsColNumber(ByVal iColumnLetter As String) As Long Const C_ASCII_DELTA = 64 Dim str As String: str = StrReverse(UCase(iColumnLetter)) Dim idx As Integer: For idx = 0 To Len(iColumnLetter) - 1 xlsColNumber = xlsColNumber + 26 ^ idx * (Asc(Mid(str, idx + 1, 1)) - C_ASCII_DELTA) Next idx End Function '/** ' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück ' * @link http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/greatest ' * @param Keine Objekte Objekte und Arrays werden als Null gerechnet ' * @return Grösster Wert ' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X '*/ Private Function greatestA(ByRef iItems As Variant) As Variant If IsObject(iItems(UBound(iItems))) Or IsArray(iItems(UBound(iItems))) Then greatestA = Null Else greatestA = iItems(UBound(iItems)) Dim item As Variant: For Each item In iItems If Not (IsObject(item) Or IsArray(item)) Then If NZ(item) > NZ(greatestA) Then greatestA = item End If Next item End Function '/** ' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück ' * @param Keine Objekte Objekte und Arrays werden als Null gerechnet ' * @return Grösster Wert ' * @example least("Hallo Welt", 42, "Mister-X") -> 42 '*/ Private Function leastA(ByRef iItems As Variant) As Variant If IsObject(iItems(LBound(iItems))) Or IsArray(iItems(LBound(iItems))) Then leastA = Null Else leastA = iItems(LBound(iItems)) Dim item As Variant: For Each item In iItems If Not (IsObject(item) Or IsArray(item)) Then If NZ(item) < NZ(leastA) Then leastA = item End If Next item End Function 'http://www.cpearson.com/excel/ShuffleArray.aspx Private Sub ShuffleArrayInPlace(InArray() As Variant) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ShuffleArrayInPlace ' This shuffles InArray to random order, randomized in place. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim N As Long Dim temp As Variant Dim j As Long Randomize For N = LBound(InArray) To UBound(InArray) j = CLng(((UBound(InArray) - N) * Rnd) + N) If N <> j Then temp = InArray(N) InArray(N) = InArray(j) InArray(j) = temp End If Next N End Sub Private Function getCollectionKeys(ByRef iCollection As Variant) As String() #If Win64 Then Const ecDelta = 28 Const nextDelta = 40 Dim CollPtr As LongPtr: CollPtr = VBA.ObjPtr(iCollection) 'Get MemoryAddress of Collection Object Dim KeyPtr As LongPtr Dim ItemPtr As LongPtr #Else Const ecDelta = 16 Const nextDelta = 24 Dim CollPtr As Long: CollPtr = VBA.ObjPtr(iCollection) 'Get MemoryAddress of Collection Object Dim KeyPtr As Long Dim ItemPtr As Long #End If Dim ElementCount As Long: ElementCount = PeekLong(CollPtr + ecDelta) 'Peek ElementCount If ElementCount <> iCollection.count Then Stop 'Verify ElementCount Dim temp() As String: ReDim temp(1 To ElementCount) 'Declare Temporary Array to hold our keys ItemPtr = PeekLong(CollPtr + nextDelta) 'Get MemoryAddress of first CollectionItem 'Loop through all CollectionItems in Chain Dim index As Long: While Not ItemPtr = 0 And index < ElementCount index = index + 1 KeyPtr = PeekLong(ItemPtr + ecDelta) 'Get MemoryAddress of Element-Key If KeyPtr <> 0 Then temp(index) = PeekBSTR(KeyPtr) 'Peek Key and add to temporary array (if present) Else temp(index) = index - 1 End If ItemPtr = PeekLong(ItemPtr + nextDelta) 'Get MemoryAddress of next Element in Chain Wend getCollectionKeys = temp End Function '/** ' * wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/xlsColLetter ' * Version : 1.0.1 ' * Gibt den Buchstaben-Key für eine ExcelSpalte anhand einer Spaltennummer aus (Beginnend mit 1) ' * ' * spaltencode = clsColLetter(spaltennummer) ' * ' * @param Long Index der Spalte ' * @return String Spaltenkey ' */ Private Function xlsColLetter(ByVal iColumnNumber As Long) As String Const C_ASCII_DELTA = 64 Dim nr As Long: nr = iColumnNumber Do Dim rest As Integer: rest = nr Mod 26 If rest = 0 Then rest = 26 xlsColLetter = Chr(rest + C_ASCII_DELTA) & xlsColLetter nr = Fix((nr - 1) / 26) Loop While nr > 0 End Function #If ms_product <> C_ACCESS Then '/** ' * Wandelt NULL in Empty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant If IsNull(iValue) Then NZ = iDefault Else NZ = iValue End If End Function #End If 'Peek Long from given MemoryAddress #If Win64 Then 'Peek LongLong from given Memory Address Private Function PeekLong(Address As LongPtr) As LongLong If Address = 0 Then Stop Call MemCopy(VBA.VarPtr(PeekLong), Address, 8&) End Function #Else Private Function PeekLong(Address As Long) As Long If Address = 0 Then Stop Call MemCopy(VBA.VarPtr(PeekLong), Address, 4&) End Function #End If 'Peek String from given MemoryAddress Private Function PeekBSTR(Address As Long) As String If Address = 0 Then Stop Dim Length As Long: Length = PeekLong(Address - 4) PeekBSTR = Space(Length \ 2) #If Win64 Then Call MemCopy(VBA.StrPtr(PeekBSTR), Address, CLngLng(Length)) #Else Call MemCopy(VBA.StrPtr(PeekBSTR), Address, Length) #End If End Function