Differences

This shows you the differences between two versions of the page.

--- deprecated:vba:dictionary [03.07.2014 11:04:07]
yaslaw [[VBA] dictionary()]
+++ deprecated:vba:dictionary [01.10.2014 10:13:03] (current)
yaslaw vba:functions:dictionary renamed to deprecated:vba:dictionary
@@ Line 1: / Line 1: @@
 ====== [VBA] dictionary() ======
-<WRAP center round download 60%>
+{{section>:snippets#deprecated&noheader&firstseconly}}
-{{:vba:functions:cls_dictionaray.bas|download box}}
+Die Neue Funktion heisst [[vba:cast:cdict]]
-</WRAP>
+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 =====
+<code vb>Public Function dictionary(ParamArray iItems() As Variant) As Object</code>
+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 =====
@@ Line 10: / Line 26: @@
 ==== Variante: Parameterliste (dListSimple) ====
-Eine einfache Liste von Werten ohne key
+Eine einfache Liste von Werten ohne key. Der Parameter <wrap hi>dListSimple ist NICHT optional</wrap>
 <code>dictionary(dListSimple, value1 [,value2... [,value#]])</code>
 <code vb>print_r dictionary(dListSimple, "a", "b", "c")
@@ Line 39: / Line 55: @@
 ==== Variante: Ein Array mit allen Keys, der Zweite mit allen Values (dCombine) ====
-Zwei Parameter werden mitgegeben werden.Der Erste beinhaltet alle Keys, der Zweite di dazugehörigen Values
+Zwei Parameter werden mitgegeben werden.Der Erste beinhaltet alle Keys, der Zweite die dazugehörigen Values
 <code>dictionary([dCombine,] array(key1 [,key2... [,key#]]), array(value1[, value2...[, value#]]))</code>
 <code vb>print_r dictionary(array("A", "B"), array("aa", "bb"))
@@ Line 48: / Line 64: @@
 ==== Varainte: Eine beliebige Anzahl Dictionaries (dDictionary) ====
-Alle Parametersind Dictionaries. DIese werden zusammengeführt zu einem
+Alle Parameter sind Dictionaries. DIese werden zusammengeführt zu einem
 <code>dictionary([dDictionary,] dictionary1 [,dictionary2... [,dictionary#]])</code>
 <code vb>print_r dictionary(dictionary(dListSimple, 1,2,3), dictionary("A","a","B","b"))
@@ Line 59: / Line 75: @@
 )</code>
-==== Variante: Ein Array in ein Dictionary wandeln (dArray= ====
+==== Variante: Ein Array in ein Dictionary wandeln (dArray) ====
 Hat nur ein Array als Parameter. Aus dem Array wird ein Dictionary erstellt
 <code>dictionary([dArray,] array(value1 [,value2... [,value#]]))</code>
@@ Line 68: / Line 84: @@
     [2] => <String> 'cc'
 )</code>
+===== Code =====
+<code vb cls_dictionary.bas>'-------------------------------------------------------------------------------
+'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<Variant>
+' * @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<Varaint>
+' * @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<Array<Variant>>
+' */
+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<Dictionary>
+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<Variant>
+'*/
+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<Variant>
+' */
+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<Array<Variant>>
+' */
+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<Array<Variant>>
+' */
+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</code>

Yaslaw.Info

User Tools

Site Tools

Differences

Page Tools