VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Dictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
''
' Dictionary v1.2.0
' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary
'
' Drop-in replacement for Scripting.Dictionary on Mac
'
' @author: tim.hall.engr@gmail.com
' @license: MIT (http://www.opensource.org/licenses/mit-license.php
'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
Option Explicit

' --------------------------------------------- '
' Constants and Private Variables
' --------------------------------------------- '

#Const UseScriptingDictionaryIfAvailable = True

#If Mac Or Not UseScriptingDictionaryIfAvailable Then

' KeyValue 0: FormattedKey, 1: OriginalKey, 2: Value
Private pKeyValues As Collection
Private pKeys() As Variant
Private pItems() As Variant
Private pCompareMode As CompareMethod

#Else

Private pDictionary As Object

#End If

' --------------------------------------------- '
' Types
' --------------------------------------------- '

Public Enum CompareMethod
    BinaryCompare = vbBinaryCompare
    TextCompare = vbTextCompare
    DatabaseCompare = vbDatabaseCompare
End Enum

' --------------------------------------------- '
' Properties
' --------------------------------------------- '

Public Property Get CompareMode() As CompareMethod
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    CompareMode = pCompareMode
#Else
    CompareMode = pDictionary.CompareMode
#End If
End Property
Public Property Let CompareMode(Value As CompareMethod)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        ' Can't change CompareMode for Dictionary that contains data
        ' http://msdn.microsoft.com/en-us/library/office/gg278481(v=office.15).aspx
        Err.Raise 5 ' Invalid procedure call or argument
    End If
    
    pCompareMode = Value
#Else
    pDictionary.CompareMode = Value
#End If
End Property

Public Property Get Count() As Long
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Count = pKeyValues.Count
#Else
    Count = pDictionary.Count
#End If
End Property

Public Property Get Item(Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(Key)
    
    If Not IsEmpty(KeyValue) Then
        If IsObject(KeyValue(2)) Then
            Set Item = KeyValue(2)
        Else
            Item = KeyValue(2)
        End If
    Else
        ' Not found -> Returns Empty
    End If
#Else
    If IsObject(pDictionary.Item(Key)) Then
        Set Item = pDictionary.Item(Key)
    Else
        Item = pDictionary.Item(Key)
    End If
#End If
End Property
Public Property Let Item(Key As Variant, Value As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Exists(Key) Then
        ReplaceKeyValue GetKeyValue(Key), Key, Value
    Else
        AddKeyValue Key, Value
    End If
#Else
    pDictionary.Item(Key) = Value
#End If
End Property
Public Property Set Item(Key As Variant, Value As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Exists(Key) Then
        ReplaceKeyValue GetKeyValue(Key), Key, Value
    Else
        AddKeyValue Key, Value
    End If
#Else
    Set pDictionary.Item(Key) = Value
#End If
End Property

Public Property Let Key(Previous As Variant, Updated As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(Previous)
    
    If Not IsEmpty(KeyValue) Then
        ReplaceKeyValue KeyValue, Updated, KeyValue(2)
    End If
#Else
    pDictionary.Key(Previous) = Updated
#End If
End Property

' ============================================= '
' Public Methods
' ============================================= '

''
' Add an item with the given key
'
' @param {Variant} Key
' @param {Variant} Item
' --------------------------------------------- '
Public Sub Add(Key As Variant, Item As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Not Me.Exists(Key) Then
        AddKeyValue Key, Item
    Else
        ' This key is already associated with an element of this collection
        Err.Raise 457
    End If
#Else
    pDictionary.Add Key, Item
#End If
End Sub

''
' Check if an item exists for the given key
'
' @param {Variant} Key
' @return {Boolean}
' --------------------------------------------- '
Public Function Exists(Key As Variant) As Boolean
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Exists = Not IsEmpty(GetKeyValue(Key))
#Else
    Exists = pDictionary.Exists(Key)
#End If
End Function

''
' Get an array of all items
'
' @return {Variant}
' --------------------------------------------- '
Public Function items() As Variant
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        items = pItems
    Else
        ' Split("") creates initialized empty array that matches Dictionary Keys and Items
        items = Split("")
    End If
#Else
    items = pDictionary.items
#End If
End Function

''
' Get an array of all keys
'
' @return {Variant}
' --------------------------------------------- '
Public Function Keys() As Variant
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    If Me.Count > 0 Then
        Keys = pKeys
    Else
        ' Split("") creates initialized empty array that matches Dictionary Keys and Items
        Keys = Split("")
    End If
#Else
    Keys = pDictionary.Keys
#End If
End Function

''
' Remove an item for the given key
'
' @param {Variant} Key
' --------------------------------------------- '
Public Sub Remove(Key As Variant)
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Dim KeyValue As Variant
    KeyValue = GetKeyValue(Key)
    
    If Not IsEmpty(KeyValue) Then
        RemoveKeyValue KeyValue
    Else
        ' Application-defined or object-defined error
        Err.Raise 32811
    End If
#Else
    pDictionary.Remove Key
#End If
End Sub

''
' Remove all items
' --------------------------------------------- '
Public Sub RemoveAll()
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = New Collection
    
    Erase pKeys
    Erase pItems
#Else
    pDictionary.RemoveAll
#End If
End Sub

' ============================================= '
' Private Functions
' ============================================= '

#If Mac Or Not UseScriptingDictionaryIfAvailable Then

Private Function GetKeyValue(Key As Variant) As Variant
    On Error Resume Next
    GetKeyValue = pKeyValues(GetFormattedKey(Key))
    Err.Clear
End Function

Private Sub AddKeyValue(Key As Variant, Value As Variant, Optional Index As Long = -1)
    If Me.Count = 0 Then
        ReDim pKeys(0 To 0)
        ReDim pItems(0 To 0)
    Else
        ReDim Preserve pKeys(0 To UBound(pKeys) + 1)
        ReDim Preserve pItems(0 To UBound(pItems) + 1)
    End If
    
    Dim FormattedKey As String
    FormattedKey = GetFormattedKey(Key)
    
    If Index > 0 And Index <= pKeyValues.Count Then
        Dim i As Long
        For i = UBound(pKeys) To Index Step -1
            pKeys(i) = pKeys(i - 1)
            If IsObject(pItems(i - 1)) Then
                Set pItems(i) = pItems(i - 1)
            Else
                pItems(i) = pItems(i - 1)
            End If
        Next i
        
        pKeys(Index - 1) = Key
        If IsObject(Value) Then
            Set pItems(Index - 1) = Value
        Else
            pItems(Index - 1) = Value
        End If
        
        pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey, Before:=Index
    Else
        pKeys(UBound(pKeys)) = Key
        If IsObject(Value) Then
            Set pItems(UBound(pItems)) = Value
        Else
            pItems(UBound(pItems)) = Value
        End If
        
        pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey
    End If
End Sub

Private Sub ReplaceKeyValue(KeyValue As Variant, Key As Variant, Value As Variant)
    Dim Index As Long
    Dim i As Integer
    
    For i = 0 To UBound(pKeys)
        If pKeys(i) = KeyValue(1) Then
            Index = i + 1
            Exit For
        End If
    Next i
    
    ' Remove existing value
    RemoveKeyValue KeyValue, Index
    
    ' Add new key value back
    AddKeyValue Key, Value, Index
End Sub

Private Sub RemoveKeyValue(KeyValue As Variant, Optional ByVal Index As Long = -1)
    Dim i As Long
    If Index = -1 Then
        For i = 0 To UBound(pKeys)
            If pKeys(i) = KeyValue(1) Then
                Index = i
            End If
        Next i
    Else
        Index = Index - 1
    End If
    
    If Index >= 0 And Index <= UBound(pKeys) Then
        For i = Index To UBound(pKeys) - 1
            pKeys(i) = pKeys(i + 1)
            
            If IsObject(pItems(i + 1)) Then
                Set pItems(i) = pItems(i + 1)
            Else
                pItems(i) = pItems(i + 1)
            End If
        Next i
        
        If UBound(pKeys) = 0 Then
            Erase pKeys
            Erase pItems
        Else
            ReDim Preserve pKeys(0 To UBound(pKeys) - 1)
            ReDim Preserve pItems(0 To UBound(pItems) - 1)
        End If
    End If
    
    pKeyValues.Remove KeyValue(0)
End Sub

Private Function GetFormattedKey(Key As Variant) As String
    GetFormattedKey = CStr(Key)
    If Me.CompareMode = CompareMethod.BinaryCompare Then
        ' Collection does not have method of setting key comparison
        ' So case-sensitive keys aren't supported by default
        ' -> Approach: Append lowercase characters to original key
        '    AbC -> AbC__b, abc -> abc__abc, ABC -> ABC
        '    Won't work in very strange cases, but should work for now
        '    AbBb -> AbBb__bb matches AbbB -> AbbB__bb
        Dim Lowercase As String
        Lowercase = ""
        
        Dim i As Integer
        Dim Ascii As Integer
        Dim Char As String
        For i = 1 To Len(GetFormattedKey)
            Char = VBA.Mid$(GetFormattedKey, i, 1)
            Ascii = Asc(Char)
            If Ascii >= 97 And Ascii <= 122 Then
                Lowercase = Lowercase & Char
            End If
        Next i
        
        If Lowercase <> "" Then
            GetFormattedKey = GetFormattedKey & "__" & Lowercase
        End If
    End If
End Function

#End If

Private Sub Class_Initialize()
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = New Collection
    
    Erase pKeys
    Erase pItems
#Else
    Set pDictionary = CreateObject("Scripting.Dictionary")
#End If
End Sub

Private Sub Class_Terminate()
#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    Set pKeyValues = Nothing
#Else
    Set pDictionary = Nothing
#End If
End Sub