Attribute VB_Name = "cls_dictionaray"
'-------------------------------------------------------------------------------
'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
'
' ** Variant dListSimple **           Die Parameterliste
' Die Parameter sind immer abwechselnd key, value, key, value etc
'
'       dictionary(dListSimple, value1 [,value2... [,value#]])
'
' ** Variant dListInclKeys **           Die Parameterliste
' Die Parameter sind immer abwechselnd key, value, key, value etc
'
'       dictionary([dListInclKeys,] key1, value1 [,key2, value2... [,key#, value#]])
'
' ** Variant 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 di 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