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      : 2.0.0
'Name         : cDict
'Author       : Stefan Erb (ERS)
'History      : 19.06.2014 - ERS - Creation
'               23.06.2014 - ERS
'               30.06.2014 - ERS - kleine Korrektur
'               08.09.2014 - ERS - Umbennent auf cDict, Logik neu aufgebaut
'-------------------------------------------------------------------------------
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)

'-------------------------------------------------------------------------------
'-- Private members for cDict()
'-------------------------------------------------------------------------------
Private Const C_SETSTRING_PATTERN = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*(?:>=|[:=])\s*(?:\]([^\[]+)\[|(['""])(?!\\)(.+?)\5(?!\\)|(\w+))"
Private rxCachedSetString As Object

'-------------------------------------------------------------------------------
'-- Public methodes
'-------------------------------------------------------------------------------

'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * @param  ParamArray
' * @return Dictionary
' */
Public Function cDict(ParamArray iItems() As Variant) As dictionary
    Set cDict = New dictionary
    Dim items() As Variant: items = CVar(iItems)
    Dim i As Integer, 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
            key = items(0): value = items(1)
            Dim delta As Long: delta = LBound(key) - LBound(value)
            ReDim Preserve value(LBound(value) To UBound(key) + delta)
            For i = LBound(key) To UBound(key)
                If Not cDict.exists(key(i)) Then cDict.add key(i), value(i + delta)
            Next i
            Exit Function
        End If
    End If
    
    'Alle Items durchackern
    For i = 0 To UBound(items)
        Dim item As Variant: ref item, items(i)
        'Dictionary
        If TypeName(item) = "Dictionary" Then
            For Each key In items(i).keys
                If Not cDict.exists(key) Then cDict.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDict.exists(key) Then cDict.add key, item(key)
            Next key
        'SetString
        ElseIf rxSetString.Test(StrReverse(item)) Then
            Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
            Dim k As Integer: For k = mc.count - 1 To 0 Step -1
                Dim m As Object: Set m = mc(k)
                key = StrReverse(firstValue(m.SubMatches(6), m.SubMatches(5), m.SubMatches(3)))
                value = StrReverse(firstValue(m.SubMatches(2), m.SubMatches(1)))
                Select Case m.SubMatches(0)
                    Case "#":   value = eval("#" & value & "#")
                    Case Empty: value = CDec(value)
                    Case Else:  value = cRegExp("\\(['""])", rxpGlobal).Replace(value, "$1")
                End Select
                If Not cDict.exists(key) Then cDict.add key, value
            Next k
        'Alles andere geht in ein WertePaar.
        ElseIf i = 0 Or isList Then
            If i Mod 2 = 0 Then
                key = item
            Else
                If Not cDict.exists(key) Then cDict.add key, item
            End If
            isList = True
        End If
    Next i
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And i Mod 2 <> 0 Then
        If Not cDict.exists(key) Then cDict.add key, Empty
    End If
End Function

'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------
'/**
' * Gibt den ersten Wert zurück, der nicht Nothing, Empty oder Null ist
' * @param  ParamArray
' * @return Variant
' */
Private Function firstValue(ParamArray items() As Variant) As Variant
    For Each firstValue In items
        If IsObject(firstValue) Then
            If Not firstValue Is Nothing Then Exit For
        Else
            If Not IsNull(firstValue) And Not firstValue = Empty Then Exit For
        End If
    Next
End Function

'/**
' * Gibt eine Refernez auf den Wert zurück
' * @param  Variant     Variable, di abgefüllt werden soll
' * @param  Variant     Value
' */
Private Sub ref(ByRef oItem As Variant, Optional ByRef iItem As Variant)
    If IsMissing(iItem) Then
        oItem = Empty
    ElseIf IsObject(iItem) Then
        Set oItem = iItem
    Else
        oItem = iItem
    End If
End Sub

'/**
' * Handelt den RegExp-Cache um ein Set-String zu zerlegen
' * @return RegExp
' */
Private Property Get rxSetString() As Object
    If rxCachedSetString Is Nothing Then
        Set rxCachedSetString = CreateObject("VBScript.RegExp")
        rxCachedSetString.Global = True
        rxCachedSetString.pattern = C_SETSTRING_PATTERN
    End If
    Set rxSetString = rxCachedSetString
End Property