====== [VBA] dictionary() ======
{{section>:snippets#deprecated&noheader&firstseconly}}
Die Neue Funktion heisst [[vba:cast:cdict]]
Download{{:vba:functions:cls_dictionaray.bas|cls_dictionaray.bas}}
Ich arbeite viel mit Dictionaries. Aber das erstellen ist immer relativ anstrengend. Darum habe ich die Funktion dictionary geschrieben. Mit der kann man mit einem einfachen Einzeiler ein Dictionaray erstellen und abfüllen
===== Definition =====
Public Function dictionary(ParamArray iItems() As Variant) As Object
Der erste Parameter kann bereits zu den Daten gehören oder es ist ein Eintrag aus dem Enum dFillType.
==== dFillType ====
***dListSimple** Einfache Liste ohne Keys. wird nur erkannt, wenn es direkt angegeben wurde
***dListInclKeys** Liste, Key und Value abwechselnd
***dArrayPairs** Ein Array pro Key/Value Paar
***dCombine** 2 Arrays: Keys und Values
***dDictionary** Die Elemente sind Dictionaries, die zusammengesetzt werden
***dArray** Ein einzelner Array soll zu einem Dictionary geparst werden. Index->Keys, Values->Values
===== Beispiele =====
> Für die Ausgabe der Resultate verwendete ich die Funktion [[vba:functions:print_r:index]]
==== Variante: Parameterliste (dListSimple) ====
Eine einfache Liste von Werten ohne key. Der Parameter dListSimple ist NICHT optional
dictionary(dListSimple, value1 [,value2... [,value#]])
print_r dictionary(dListSimple, "a", "b", "c")
(
[0] => 'a'
[1] => 'b'
[2] => 'c'
)
==== Variante: Parameterliste mit Keys (dListInclKeys) ====
Die Parameter sind immer abwechselnd key, value, key, value etc
dictionary([dListInclKeys,] key1, value1 [,key2, value2... [,key#, value#]])
print_r dictionary("A", "aa", "B", "bb", "C", "cc")
(
[A] => 'aa'
[B] => 'bb'
[C] => 'cc'
)
==== Variante: Arrays mit dem key-value Paar (dArrayPairs) ====
Die Parameter sind Arrays. Jede Array hat als ersen Eintrag den Key, als Zweiten Eintrag den Value. Den Type dArrayPairs kann man weglassen, wenn man mehr als 2 Arrays hat. Ansonsten hat der Type dCombine vorrang
dictionary([dArrayPairs,] array(key1, value1) [,array(key2, value2)... [,array(key#, value#)]])
print_r dictionary(dArrayPairs, array("A", "aa"), array("B", "bb"))
(
[A] => 'aa'
[B] => 'bb'
)
==== Variante: Ein Array mit allen Keys, der Zweite mit allen Values (dCombine) ====
Zwei Parameter werden mitgegeben werden.Der Erste beinhaltet alle Keys, der Zweite die dazugehörigen Values
dictionary([dCombine,] array(key1 [,key2... [,key#]]), array(value1[, value2...[, value#]]))
print_r dictionary(array("A", "B"), array("aa", "bb"))
(
[A] => 'aa'
[B] => 'bb'
)
==== Varainte: Eine beliebige Anzahl Dictionaries (dDictionary) ====
Alle Parameter sind Dictionaries. DIese werden zusammengeführt zu einem
dictionary([dDictionary,] dictionary1 [,dictionary2... [,dictionary#]])
print_r dictionary(dictionary(dListSimple, 1,2,3), dictionary("A","a","B","b"))
(
[0] => 1
[1] => 2
[2] => 3
[A] => 'a'
[B] => 'b'
)
==== Variante: Ein Array in ein Dictionary wandeln (dArray) ====
Hat nur ein Array als Parameter. Aus dem Array wird ein Dictionary erstellt
dictionary([dArray,] array(value1 [,value2... [,value#]]))
print_r dictionary(array("aa","bb","cc"))
(
[0] => 'aa'
[1] => 'bb'
[2] => 'cc'
)
===== Code =====
'-------------------------------------------------------------------------------
'File : cls_dictionaray.bas
' Copyright mpl by ERB software
' All rights reserved
' http://wiki.yaslaw.info/dokuwiki/doku.php/vba
'Environment : VBA 2010 +
'Version : 1.0.2
'Name : dictionary
'Author : Stefan Erb (ERS)
'History : 19.06.2014 - ERS - Creation
' 23.06.2014 - ERS
' 30.06.2014 - ERS - kleine Korrektur
'-------------------------------------------------------------------------------
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 dListSimple ** Die Parameterliste
' Die Parameter sind immer abwechselnd key, value, key, value etc
'
' dictionary(dListSimple, value1 [,value2... [,value#]])
'
' ** Variante dListInclKeys ** Die Parameterliste
' Die Parameter sind immer abwechselnd key, value, key, value etc
'
' dictionary([dListInclKeys,] key1, value1 [,key2, value2... [,key#, value#]])
'
' ** Variante dArrayPairs ** Arrays mit dem key-value Paar
' Die Parameter sind Arrays. Jede Array hat als ersen Eintrag den Key, als Zweiten Eintrag den Value
'
' dictionary([dArrayPairs,] array(key1, value1) [,array(key2, value2)... [,array(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
'
' dictionary([dCombine,] array(key1 [,key2... [,key#]]), array(value1[, value2...[, value#]]))
'
' ** Varainte dDictionary ** Eine beliebige Anzahl Dictionaries
' Alle Parametersind Dictionaries. DIese werden zusammengeführt zu einem
'
' dictionary([dDictionary,] dictionary1 [,dictionary2... [,dictionary#]])
'
' ** VariantedArray ** Ein Array in ein Dictionary wandeln
' Hat nur ein Array als Parameter. Aus dem Array wird ein Dictionary erstellt
'
' dictionary([dArray,] array(value1 [,value2... [,value#]]))
'-------------------------------------------------------------------------------
'-- Public members
'-------------------------------------------------------------------------------
Public Enum dFillType
[_FIRST] = -2147221600
dListSimple = [_FIRST] 'Einfache Liste ohne Keys. wird nur erkannt, wenn es direkt angegeben wurde
dListInclKeys 'Liste, Key und Value abwechselnd
dArrayPairs 'Ein Array pro Key/Value Paar
dCombine '2 Arrays: Keys und Values
dDictionary 'Die Elemente sind Dictionaries, die zusammengesetzt werden
dArray 'Ein einzelner Array soll zu einem Dictionary geparst werden. Index->Keys, Values->Values
[_LAST] = dArray
End Enum
'-------------------------------------------------------------------------------
'-- Public Methodes
'-------------------------------------------------------------------------------
'/**
' * Erstellt ein Dictionary-Object mit Werten
' * @param ParamArray
' * @return Dictionary
' */
Public Function dictionary(ParamArray iItems() As Variant) As Object
If UBound(iItems) = -1 Then Exit Function
Dim items() As Variant: items = CVar(iItems)
Dim fillType As dFillType
'Einziger Fall wo der erste Paramater eine Zahl sein kann ohne dass es sich um eine Type-Angabe handelt -> dListInclKeys
'Merkmale ungerade Anzahl Items
'Verwechslungen: dictionary(1, array("a","b")) mit dictionary(dArrayPairs, array("a","b"))
'Darum: Priorität hat immer dArray! dListInclKeys kann mit einem Type gesendet werden um klarjeit zu schaffen: dictionary(dListInclKeys, 1, array("a","b"))
'Erstes eine Nummer und eine ungerade Zahl an Items -> Mit Typeangabe
If IsNumeric(items(0)) Then
'Prüfen ob der erste Parameter ein dFillType ist
If between(items(0), dFillType.[_FIRST], dFillType.[_LAST]) Then
If (UBound(items) + 1) Mod 2 = 0 Then
'Versuche eine Key-Value Liste zu erstellen
fillType = arrayShift(items)
If createDict(fillType, items, dictionary) Then
Exit Function
Else
items = CVar(iItems)
createDict dListInclKeys, items, dictionary
Exit Function
End If
Else
fillType = arrayShift(items) 'fillType extrahieren und aus der itmes-Liste entfernen
End If
Else
fillType = evalfillType(items) 'fillType selber herausfinden
End If
Else
fillType = evalfillType(items) 'fillType selber herausfinden
End If
'entsprechendes Dictionary erstellen und mit Daten befüllen
Call createDict(fillType, items, dictionary)
End Function
'-------------------------------------------------------------------------------
'-- Private Methodes
'-------------------------------------------------------------------------------
'/**
' * Finder den fillType anhand der Parameters heraus
' * @param Array
' * @return dFillType
' */
Private Function evalfillType(ByRef iItems() As Variant) As dFillType
'Genau 2 Params und beide sind Arrays und haben dieselbe Grösse
If UBound(iItems) = 1 Then 'genau 2 Parameter
If IsArray(iItems(0)) And IsArray(iItems(1)) Then 'Beide Parameter sind Arrays
Dim keys() As Variant: keys = iItems(0)
Dim values() As Variant: values = iItems(1)
If (UBound(keys) - LBound(keys)) = (UBound(values) - LBound(values)) Then 'Beide Arrays sind gleich gross
evalfillType = dCombine
Exit Function
End If
End If
End If
'Genau ein Array -> dArray
If IsArray(iItems(0)) And UBound(iItems) = 0 Then
evalfillType = dArray
'Mehre Arrays -> dArrayPairs
ElseIf IsArray(iItems(0)) Then
evalfillType = dArrayPairs
'Erster Parameteristien Dictionary -> dDictionary
ElseIf TypeName(iItems(0)) = "Dictionary" Then
evalfillType = dDictionary
'Ansonsten ist es eine normale Liste -> dListInclKeys
Else
If (UBound(iItems) + 1) Mod 2 <> 0 Then Err.Raise 450 '450 Wrong number of arguments or invalid property assignment
evalfillType = dListInclKeys
End If
End Function
'/**
' * Erstellt ein Dictionary und befüllt es je nach fillType
' * @pram dFillType
' * @param Array
' * @return Dictionary
' */
Private Function createDict(ByVal iFillType As dFillType, ByRef iItems() As Variant, ByRef oDict As Object) As Boolean
Set oDict = CreateObject("scripting.Dictionary") 'Dictionary erstellen
Select Case iFillType 'Dictionary befüllen
Case dListSimple: createDict = fillByListSimple(oDict, iItems)
Case dListInclKeys: createDict = fillByListInclKeys(oDict, iItems)
Case dArrayPairs: createDict = fillByArrayPairs(oDict, iItems)
Case dCombine: createDict = fillByCombine(oDict, iItems)
Case dDictionary: createDict = fillByDictionary(oDict, iItems)
Case dArray: createDict = fillByArray(oDict, iItems)
End Select
End Function
'/**
' * Füllt ein Array ab
' * @param Dictionary
' * @param Array>
' */
Private Function fillByArray(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim arr As Variant: arr = iItems(LBound(iItems))
Dim idx As Integer: For idx = LBound(arr) To UBound(arr)
ioDict.add idx, arr(idx)
Next idx
fillByArray = True
Exit_Handler:
End Function
'/**
' * Alle elemente sind Dictionaries. Es wird ein Merge durchgeführt
' * Bei mehreren Dictionarys und überschneidenden Keys ist das erste Dictionaryder Master
' * @param Dictionary
' * @param Array
Private Function fillByDictionary(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems)
Dim key As Variant: For Each key In iItems(idx).keys
If Not ioDict.exists(key) Then ioDict.add key, iItems(idx).item(key)
Next key
Next idx
fillByDictionary = True
Exit_Handler:
End Function
'/**
' * Ein einfache Liste, Jedes Item ist ein Wert
' * @param Dictionary
' * @param Array
'*/
Private Function fillByListSimple(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim idx As Integer: For idx = 0 To UBound(iItems)
ioDict.add idx, iItems(idx)
Next idx
fillByListSimple = True
Exit_Handler:
End Function
'/**
' * Eine Liste abfüllen.
' * @param Dictionary
' * @param Array
' */
Private Function fillByListInclKeys(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems) Step 2
On Error Resume Next
ioDict.add iItems(idx), iItems(idx + 1)
If Err.Number = 5 Then
On Error GoTo 0: Err.Raise 13 '13 Type mismatch
ElseIf Err.Number > 0 Then
On Error GoTo Exit_Handler: Err.Raise Err.Number
End If
On Error GoTo 0
Next idx
fillByListInclKeys = True
Exit_Handler:
End Function
'/**
' * Array-Paare abfüllen
' * @param Dictionary
' * @param Array>
' */
Private Function fillByArrayPairs(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim idx As Integer: For idx = LBound(iItems) To UBound(iItems)
ioDict.add iItems(idx)(0), iItems(idx)(1)
Next idx
fillByArrayPairs = True
Exit_Handler:
End Function
'/**
' * Erster Array beinhaltet die Keys, der 2te die Values
' * @param Dictionary
' * @param Array>
' */
Private Function fillByCombine(ByRef ioDict As Object, ByRef iItems() As Variant) As Boolean
On Error GoTo Exit_Handler
Dim keys() As Variant: keys = iItems(LBound(iItems))
Dim values() As Variant: values = iItems(LBound(iItems) + 1)
Dim delta As Integer: delta = LBound(keys) - LBound(values) 'Indexunterschied ermitteln
Dim idx As Integer: For idx = LBound(keys) To UBound(keys)
ioDict.add keys(idx), values(idx + delta)
Next idx
fillByCombine = True
Exit_Handler:
End Function
'-------------------------------------------------------------------------------
'-- Libraries
'-------------------------------------------------------------------------------
'/**
' * analog zu array_shift aus PHP
' * liefert den ersten Wert von array , verschiebt die anderen Werte hinunter, und verkürzt array um ein Element.
' * Alle numerischen Schlüssel werden so modifiziert, dass bei null zu zählen begonnen wird.
' * Ist array leer (oder kein Array), wird NULL zurückgegeben.
' */
Private Function arrayShift(ByRef ioArray As Variant) As Variant
On Error GoTo Err_Handler
ref arrayShift, ioArray(LBound(ioArray))
Dim delta As Integer: delta = LBound(ioArray) + 1
Dim retArr() As Variant: ReDim retArr(0 To UBound(ioArray) - delta)
Dim idx As Integer: For idx = delta To UBound(ioArray)
ref retArr(idx - delta), ioArray(idx)
Next idx
ioArray = retArr
Exit_Handler:
Exit Function
Err_Handler:
arrayShift = Null
End Function
'/**
' * Ersatz für den fehlenden BETWEEN BEfehl in VBA
' * @param Variant Wert, der geprüft werden soll
' * @param Variant Untere Limite des Ranges
' * @param Variant Obere Limite de Ranges
' * @return Boolean
' */
Private Function between(ByVal iValue As Variant, ByVal iFrom As Variant, ByVal iTo As Variant) As Boolean
between = iFrom <= iValue And iValue <= iTo
End Function
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * oNode = iNode
' * @param Variant Variable, die den Wert bekommen soll
' * @param Variant Ret Wert selber
' */
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
If IsObject(iNode) Then
'Objekte als referenz übergeben
Set oNode = iNode
Else
'Je nach Datentyp der erwartet wird handeln.
Select Case TypeName(oNode)
Case "String": oNode = CStr(Nz(iNode))
Case "Integer": oNode = CInt(Nz(iNode))
Case "Long": oNode = CLng(Nz(iNode))
Case "Double": oNode = CDbl(Nz(iNode))
Case "Byte": oNode = CByte(Nz(iNode))
Case "Decimal": oNode = CDec(Nz(iNode))
Case "Currency": oNode = CCur(Nz(iNode))
Case "Date": oNode = CDate(Nz(iNode))
Case "Nothing":
Case Else: oNode = iNode
End Select
End If
End Sub