OrderedDictionary.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "OrderedDictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_Dic As Object
Private m_Keys As Collection

Private Sub Class_Initialize()
    Set m_Dic = CreateObject("Scripting.Dictionary")
    Set m_Keys = New Collection
End Sub

Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = m_Keys.[_NewEnum]
End Function

Public Sub Add(ByVal key As Variant, ByVal NewItem As Variant)
    On Error GoTo ERR_HAND
    m_Dic.Add key, NewItem
    m_Keys.Add key
    Exit Sub
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Sub

Public Property Get Count() As Long
    Count = m_Keys.Count
End Property

Public Function Exists(ByVal key As Variant) As Boolean
    Exists = m_Dic.Exists(key)
End Function

Public Property Get Item(ByVal key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
    On Error GoTo ERR_HAND
    If IsObject(m_Dic(key)) Then
        Set Item = m_Dic(key)
    Else
        Item = m_Dic(key)
    End If
    Exit Property
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Property

Public Property Let Item(ByVal key As Variant, ByVal NewItem As Variant)
    On Error Resume Next
    Me.Remove key
   
    On Error GoTo ERR_HAND
    Me.Add key, NewItem
    Exit Property
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Property

Public Function Items() As Variant()
    Items = m_Dic.Items
End Function

Public Function Keys() As Variant()
    On Error Resume Next
    Keys = CollectionToArray(m_Keys)
    Exit Function
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Function

Public Sub Remove(ByVal key As Variant)
    If Not m_Dic.Exists(key) Then
        Exit Sub
    End If
    On Error GoTo ERR_HAND
    m_Dic.Remove key
    
    Dim i As Integer
    For i = 1 To m_Keys.Count
        If m_Keys(i) = key Then
            m_Keys.Remove i
            Exit Sub
        End If
    Next
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Sub

Public Sub RemoveAll()
    On Error GoTo ERR_HAND
    m_Dic.RemoveAll
    Set m_Keys = Nothing
    Set m_Keys = New Collection
    Exit Sub
ERR_HAND:
    Err.Raise Err.Number, "OrderedDictionary Class", Err.Description
End Sub

Public Function Inspect() As String
    Dim key As Variant
    Dim result As String
    result = "{"
    For Each key In Me
        If result <> "{" Then
            result = result & ", "
        End If

        result = result & key & ": "
        If TypeName(Me(key)) = "OrderedDictionary" Then
            result = result & Me(key).Inspect
        ElseIf TypeName(Me(key)) = "Collection" Then
            result = result & "[" & Join(CollectionToArray(Me(key)), ", ") & "]"
        ElseIf IsObject(Me(key)) Then
            result = result & TypeName(Me(key))
        Else
            result = result & Me(key)
        End If
    Next
    result = result & "}"
    
    Inspect = result
End Function

Private Function CollectionToArray(col As Collection) As Variant()
    Dim result As Variant
    ReDim result(1 To col.Count)
    
    Dim i As Integer
    For i = 1 To col.Count
        If IsObject(col(i)) Then
            Set result(i) = col(i)
        Else
            result(i) = col(i)
        End If
    Next
    CollectionToArray = result
End Function