Einfaches erstellen eines Dictionarays aus Arrays, Collections, String, Wertesammlungen.

Diese Funktion erstellt auf verschiedene Arten ein Dictionary.
Die Funktion alleinstehend macht mässig Sinn. ich brauche sie aber immer mal wieder in anderen Funktionen. zB [VBA] strReplace()

Download cast_cdict.bas (V-3.1.3)

Um aus einem JSON-String ein Dictionary zu erstellen habe ich die Libraray [VBA] JSON erstellt.

Darum wird dasnicht in der Funktion cDict() abgehandelt

Es gibt verschiedene Varianten um cDict() anzuwenden. Hier ist mal eine Liste verschiedener Anwendungsarten. Beispiele dazu sin weiter unten aufgeführt

Dictionary = cDict(key1, value1 [,key2, value2...[,key#, value#]])

Dictionary = cDict(array(key1 [,key2...[,key#]]), array(value1 [,value2...[,value#]])

Dictionary = cDict(array(value1 [,value2...[,value#]])

Dictionary = cDict(dictionary1 [,dictionary2...[,dictionary#]])

Dictionary = cDict(string)

Public Function cDict(ParamArray iItems() As Variant) As dictionary

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

Dictionary = cDict(key1, value1 [,key2, value2...[,key#, value#]])

Die Funktionsargumente sind abwechselnd Key, Value

'Normal: Gleich viele Keys wie Values
d cDict("A", 123, "B", now, "C", "Wert 'C'")
<Dictionary>  (
    [A] => <Integer> 123
    [B] => <Date> 08.09.2014 12:24:51
    [C] => <String> 'Wert 'C''
)
 
'ungerade Anzahl Argument. Der letzte Key hat keinen Wert
d cDict("a", "A", "b", "B", "c")
<Dictionary>  (
    [a] => <String> 'A'
    [b] => <String> 'B'
    [c] => <Empty> 
)
 
'Nur ein Key ohne Value
d cDict(2)
<Dictionary>  (
    [2] => <Empty> 
)
 
'Ohne Keys. Der Key ist Empty. Der Zweite Wert überschreibt den ersten nicht
d cDict(,2,,3)
<Dictionary>  (
    [] => <Integer> 2
)

Dictionary = cDict(array(value1 [,value2...[,value#]])

Es wird nur ein Array übergeben. Dann wird dieser Array als Value-Array in ein Dictionary gewandelt mit dem Arrayindex als Key

'Ein nicht weiter spezifizierter Array. Index beginnt bei 0
d cDict(array(123, now, "Wert 'C'"))
<Dictionary>  (
    [0] => <Integer> 123
    [1] => <Date> 08.09.2014 12:26:06
    [2] => <String> 'Wert 'C''
)
 
'Ein Array mit Index von 3 bis 5
Public Sub testCDict()
    Dim arr(3 To 5) As String
    arr(3) = "C"
    arr(4) = "D"
    arr(5) = "E"
 
    print_r cDict(arr)
End Sub
'Ausgabe:
<Dictionary>  (
    [3] => <String> 'C'
    [4] => <String> 'D'
    [5] => <String> 'E'
)

Dictionary = cDict(array(key1 [,key2...[,key#]]), array(value1 [,value2...[,value#]])

Der Funktion werden 2 Arrays übergeben. Der erste beinhaltet alle Keys, der Zweite die Values. Die Anzahl Einträge hängt nur vom Key-Array ab

'Standard: Es sind gleich viele Values wie Keys
d cDict(array("A", "B", "C"), array(123, now, "Wert 'C'"))
<Dictionary>  (
    [A] => <Integer> 123
    [B] => <Date> 08.09.2014 12:25:47
    [C] => <String> 'Wert 'C''
)
 
'Mehr Values als Keys
d cDict(Array(1,2,3), array("A", "B", "C", "D"))
<Dictionary>  (
    [1] => <String> 'A'
    [2] => <String> 'B'
    [3] => <String> 'C'
)
 
'Mehr keys wie Values
d cDict(Array(1,2,3), array(1))
<Dictionary>  (
    [1] => <Integer> 1
    [2] => <Empty> 
    [3] => <Empty> 
)

Dictionary = cDict(string)

Ein Dictionary kann auch als String beschrieben werden. So ähnlich einem Set-Statement in einem SQL. Dieser beinhalter jeweils ein Key (key in [], '' oder ""), eine Zuweisung(=>, = oder :) und einem Value ('' oder "" als Delemiter für Strings, ## für Datum und keine Delemiter für Zahlen). Es können mehrere Zuweisungen mit einem Komma getrent übergeben werden.
Ist ein Delemiter Bestandteil des Textes, kann er mit einem \ maskiert werden. Zum Beispiel 'Paddy O\'Brien'.

'2 Verschidene Zuordnungen: Zahl, Datum und Text.
'Man sieht auch die 3 verschiedenen KEy-Value Zuordnungsstrings '=>', '=', ':'
d cdict("'A'=>123456,'B':123.45,'C'=#11-1-2014#,'3.4':'abc'")
<Dictionary>  (
    [A] => <Long> 123456
    [B] => <Double> 123.45
    [C] => <Date> 11.01.2014
    [3.4] => <String> 'abc'
)
 
 
'Ein Beispiel um Delemiter zu maskieren
d cDict("A=> 'Wert \'C\'', [B] => '[x]=>2, [y] => ""3""', 'C' => ""Wert \""C\""""")
<Dictionary>  (
    [A] => <String> 'Wert 'C''
    [B] => <String> '[x]=>2, [y] => "3"'
    [C] => <String> 'Wert "C"'
)

Dictionary = cDict(dictionary1 [,dictionary2...[,dictionary#]])

Es können auch mehrere Dictionaries übergeben werden. Diese werden dann zusammengesetzt, wobei doppelte Keys nicht überschrieben werden

d cDict(cDict(array(1,2,3)), CDict("3=>4, 4=>5"))
<Dictionary>  (
    [0] => <Integer> 1
    [1] => <Integer> 2
    [2] => <Integer> 3
    [3] => <Decimal> 4
    [4] => <Decimal> 5
)

cast_cdict.bas

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