Attribute VB_Name = "cast_cDict" '------------------------------------------------------------------------------- 'File : cast_cDict.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba 'Environment : VBA 2010 + 'Version : 3.1.3 'Name : cDict 'Author : Stefan Erb (ERS) 'History : 19.06.2014 - ERS - Creation ' ..... ' 22.11.2014 - ERS - Enum cvHandling als Private hinzugefügt ' 07.01.2015 - ERS - Fehler behoben '------------------------------------------------------------------------------- Option Explicit ' Diese Function erstellt ein Dictionary. Es gibt diverse verschiedene Möglichkeiten daraus ein Dictionary zu erstellen ' Bei allen Varianten kann man den varianttyp angeben um sicher zu gehen. Er kann aber auch weggelassen werden. ' Wobei es da Konstalationen ergibt, die ev. die falsche Methode zum abfüllend er Daten verwendet. dListSimple wird nie alleine erkannt ' ' ' ** Variante dListInclKeys ** Die Parameterliste ' Die Parameter sind immer abwechselnd key, value, key, value etc ' ' cDict(key1, value1 [,key2, value2... [,key#, value#]]) ' ' ** Variante dCombine ** Ein Array mit allen Keys, der Zweite mit allen Values ' Zwei Parameter werden mitgegeben werden.Der Erste beinhaltet alle Keys, der Zweite die dazugehörigen Values ' ' cDict(array(key1 [,key2... [,key#]]), array(value1[, value2...[, value#]])) ' ' ** Varainte dDictionary ** Eine beliebige Anzahl Dictionaries ' Alle Parametersind Dictionaries. DIese werden zusammengeführt zu einem ' ' cDict(dictionary1 [,dictionary2... [,dictionary#]]) ' ' ** VariantedArray ** Ein Array in ein Dictionary wandeln ' Hat nur ein Array als Parameter. Aus dem Array wird ein Dictionary erstellt ' ' cDict(array(value1 [,value2... [,value#]])) ' ' ** SetString ** ' cDict(string) '------------------------------------------------------------------------------- '-- Public methodes '------------------------------------------------------------------------------- '/** ' * Wandelt verschiedene Formate in ein Dictionary um ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic ' * @param ParamArray ' * @return Dictionary ' */ Public Function cDict(ParamArray iItems() As Variant) As Object Dim items() As Variant: items = CVar(iItems) Set cDict = cDictA(items) End Function '/** ' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry. ' * Dieser Aufruf wird vor allem im Einsatz in anderen Funktionen verwendet ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic ' * @param Array ' * @return Dictionary ' */ Public Function cDictA(ByRef iItems() As Variant) As Object 'Cache RegExp um einSet-String zu zerlegen Static rxSetString As Object: If rxSetString Is Nothing Then Set rxSetString = cRx("/(|lluN|eslaf|eurt|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/i") Static rxCharsInStringToUnicode As Object: If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,])/") Static rxStrings As Object: If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""])([^\1]+?)\1/g") Set cDictA = CreateObject("scripting.Dictionary") Dim mc As Object Dim items() As Variant: items = CVar(iItems) Dim key As Variant, value As Variant Dim isList As Boolean If UBound(items) = -1 Then Exit Function 'Prüfen ob 2 Parametetrs übergeben wurden If UBound(items) = 1 Then 'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values If IsArray(items(0)) And IsArray(items(1)) Then Dim keys() As Variant: keys = items(0) Dim values() As Variant: values = items(1) Dim delta As Long: delta = LBound(keys) - LBound(values) ReDim Preserve values(LBound(values) To UBound(keys) + delta) Dim i As Integer: For i = LBound(keys) To UBound(keys) If Not cDictA.exists(keys(i)) Then cDictA.add keys(i), values(i + delta) Next i Exit Function End If End If 'Alle Items durchackern Dim cnt As Integer: cnt = 0 Dim item As Variant: For Each item In items 'Dictionary If Not isList And TypeName(item) = "Dictionary" Then For Each key In item.keys If Not cDictA.exists(key) Then cDictA.add key, item.item(key) Next key 'einsamer Array ElseIf Not isList And IsArray(item) Then For key = LBound(item) To UBound(item) If Not cDictA.exists(key) Then cDictA.add key, item(key) Next key 'SetString ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then 'Alle []{}'"=;, innerhalb eines Strings in Unicode parsen If rxStrings.Test(item) Then Set mc = rxStrings.execute(item) For i = mc.count - 1 To 0 Step -1 Dim substr As String: substr = mc(i).subMatches(1) Do While rxCharsInStringToUnicode.Test(substr) substr = rxCharsInStringToUnicode.Replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0)))) Loop Dim dm As String: dm = mc(i).subMatches(0) item = replaceIndex(item, dm & substr & dm, mc(i).firstIndex, mc(i).length) Next i End If If rxSetString.Test(StrReverse(item)) Then Set mc = rxSetString.execute(StrReverse(item)) Dim k As Variant: For k = mc.count - 1 To 0 Step -1 key = cV(unicodeDecode(StrReverse(mc(k).subMatches(2)))) value = cV(unicodeDecode(StrReverse(mc(k).subMatches(0))), "sbd") If Not cDictA.exists(key) Then cDictA.add key, value Next k Else GoTo DEFAULT 'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden. End If 'Alles andere geht in ein WertePaar. ElseIf cnt = 0 Or isList Then DEFAULT: If cnt Mod 2 = 0 Then key = item ElseIf Not cDictA.exists(key) Then cDictA.add key, item End If isList = True End If cnt = cnt + 1 Next 'Falls es sich um eine nicht abgeschlossene Liste handelt If isList And cnt Mod 2 <> 0 Then If Not cDictA.exists(key) Then cDictA.add key, Empty End Function '------------------------------------------------------------------------------- '--- LIBRARIES for cDict '------------------------------------------------------------------------------- '/** ' * Dies ist die Minimalversion von cValue (V1.0.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cvalue ' * Der 2te Paramtersteuert das Null-Verhalten('nebd'): ' * n: Der Text Null ohne Delemiter wird als Wert Null intepretiert: "NULL" -> Null ' * e: Ein leerer String wird als Null intepretiert, "" -> Null ' * b: Boolean-Text wird als Boolean intepretiert "True" -> True (Boolean) ' * d: Bei Delemited Strings den Delemiter entfernen. ' oder " gelten als Delemiter: "'Hans'" -> Hans ' */ Private Function cV(ByVal iValue As Variant, Optional ByVal iFlags As String) As Variant On Error Resume Next: If IsNull(iValue) Then cV = Null: Exit Function Static rxDa As Object, rsDs As Object: Dim sm As Object, str As String, flg As String: str = CStr(iValue): flg = UCase(iFlags) If UCase(str) = "NULL" And InStr(flg, "N") Then cV = Null: Exit Function If iValue = Empty And CBool(InStr(flg, "E")) Then cV = Null: Exit Function If IsDate(str) Then cV = CDate(str): Exit Function cV = CByte(str): If cV = str Then Exit Function cV = CInt(str): If cV = str Then Exit Function cV = CLng(str): If cV = str Then Exit Function cV = CDbl(str): If cV = str Then Exit Function cV = CDec(str): If cV = str Then Exit Function Err.Clear: If InStr(flg, "B") Then cV = CBool(str): If Err.Number = 0 Then Exit Function If rxDa Is Nothing Then Set rxDa = CreateObject("VBScript.RegExp"): rxDa.pattern = "^#(.*)#$" If rxDa.Test(str) Then cV = CDate(rxDa.execute(str)(0).subMatches(0)): Exit Function If InStr(flg, "D") Then If rsDs Is Nothing Then Set rsDs = CreateObject("VBScript.RegExp"): rsDs.pattern = "^([""'])(.*)\1$" If rsDs.Test(str) Then Set sm = rsDs.execute(str)(0).subMatches: cV = Replace(sm(1), "\" & sm(0), sm(0)): Exit Function End If cV = iValue End Function '/** ' * Dies ist die Minimalversion von cRegExp (V2.1.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp ' */ Private Function cRx(ByVal iPattern As String) As Object Static rxP As Object If rxP Is Nothing Then: Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" Dim sm As Object: Set cRx = CreateObject("VBScript.RegExp"): Set sm = rxP.execute(iPattern)(0).subMatches cRx.pattern = sm(1): cRx.IgnoreCase = Not isEmpty(sm(2)): cRx.Global = Not isEmpty(sm(3)): cRx.Multiline = Not isEmpty(sm(4)) End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Unicode in ein Charakter ' * @example: unicode2char("\u20AC") -> '\€' ' * @param String Unicode ' * @return String Char ' */ Private Function unicode2Char(ByVal iUnicode As String) As String unicode2Char = ChrW(Replace(iUnicode, "\u", "&h")) End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Charakter in ein Unicode ' * @example: char2unicode("€") -> '\u20AC' ' * @param String(1) Charakter, der gewandelt werden soll ' * @return String Unicode ' */ Private Function char2unicode(ByVal iChar As String) As String char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Ersetzt ein pestimmte Position in einem String ' * @param String Heystack ' * @param String Ersetzungsstring ' * @param Integer Position im String ' * @param Integer Länge des zu ersetzenden Strings ' */ Private Function replaceIndex(ByVal iExpression As Variant, ByVal iReplace As Variant, ByVal iIndex As Variant, Optional ByVal iLength As Integer = 1) As String replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength + 1) End Function '/** ' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück ' * @param String ' * @return String ' */ Private Function unicodeDecode(ByVal iString) As String unicodeDecode = iString Static rx As Object If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/i") Do While rx.Test(unicodeDecode) unicodeDecode = rx.Replace(unicodeDecode, unicode2Char(rx.execute(unicodeDecode)(0))) Loop End Function