Yaslaw.Info

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
====== [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 =====
<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 =====
> 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 <wrap hi>dListSimple ist NICHT optional</wrap>
<code>dictionary(dListSimple, value1 [,value2... [,value#]])</code>
<code vb>print_r dictionary(dListSimple, "a", "b", "c")
<Dictionary>  (
    [0] => <String> 'a'
    [1] => <String> 'b'
    [2] => <String> 'c'
)</code>

==== Variante: Parameterliste mit Keys (dListInclKeys) ====
Die Parameter sind immer abwechselnd key, value, key, value etc
<code>dictionary([dListInclKeys,] key1, value1 [,key2, value2... [,key#, value#]])</code>
<code vb>print_r dictionary("A", "aa", "B", "bb", "C", "cc")
<Dictionary>  (
    [A] => <String> 'aa'
    [B] => <String> 'bb'
    [C] => <String> 'cc'
)</code>

==== 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
<code>dictionary([dArrayPairs,] array(key1, value1) [,array(key2, value2)... [,array(key#, value#)]])</code>
<code vb>print_r dictionary(dArrayPairs, array("A", "aa"), array("B", "bb"))
<Dictionary>  (
    [A] => <String> 'aa'
    [B] => <String> 'bb'
)</code>

==== 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
<code>dictionary([dCombine,] array(key1 [,key2... [,key#]]), array(value1[, value2...[, value#]]))</code>
<code vb>print_r dictionary(array("A", "B"), array("aa", "bb"))
<Dictionary>  (
    [A] => <String> 'aa'
    [B] => <String> 'bb'
)</code>

==== Varainte: Eine beliebige Anzahl Dictionaries (dDictionary) ====
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"))
<Dictionary>  (
    [0] => <Integer> 1
    [1] => <Integer> 2
    [2] => <Integer> 3
    [A] => <String> 'a'
    [B] => <String> 'b'
)</code>

==== 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>
<code vb>print_r dictionary(array("aa","bb","cc"))
<Dictionary>  (
    [0] => <String> 'aa'
    [1] => <String> 'bb'
    [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

Page Tools
