Enhanced VB6 Collection

Collection2.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Collection2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const INTERNAL_KEY_SIGNATURE  As String = "_Collection2_Internal_Key_"

Private m_items As Collection
Private m_indexes As Collection
Private m_keys As Collection

Public Sub Dispose()
    Set m_items = Nothing
    Set m_indexes = Nothing
    Set m_keys = Nothing
End Sub

Private Sub Class_Initialize()
    Set m_items = New Collection
    Set m_indexes = New Collection
    Set m_keys = New Collection
End Sub

Private Sub Class_Terminate()
    Dispose
End Sub

Public Property Get Item(Key As Variant) As Variant
Attribute Item.VB_UserMemId = 0
    Dim k As String
    
    k = m_indexes(Key)
    
    If VarType(m_items(k)) = vbObject Then
        Set Item = m_items(k)
    Else
        Item = m_items(k)
    End If
End Property

Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = m_items.[_NewEnum]
End Function

Public Sub Add(Item As Variant, Optional Key As Variant, Optional Before As Variant, Optional After As Variant)
    Dim k As Variant
    Dim b As Variant
    Dim a As Variant
    
    k = NextInternalKey()
    If IsMissing(Key) Then
        CollectionAddItem m_indexes, k, k, Before, After
    Else
        CollectionAddItem m_indexes, k, Key, Before, After
        m_keys.Add Key, k
    End If
    
    If Not IsMissing(Before) Then
        b = m_indexes(Before)
    End If
    
    If Not IsMissing(After) Then
        a = m_indexes(After)
    End If
        
    CollectionAddItem m_items, Item, k, b, a
End Sub

Private Function CollectionAddItem(a_collection As Collection, Item As Variant, Key As Variant, Before As Variant, After As Variant) As String
    If IsEmpty(Before) And IsEmpty(After) Then
        a_collection.Add Item, Key
        
    ElseIf Not IsEmpty(Before) And IsEmpty(After) Then
        a_collection.Add Item, Key, Before
        
    ElseIf IsEmpty(Before) And Not IsEmpty(After) Then
        a_collection.Add Item, Key, , After
        
    Else
        ' this will raise an expected error
        a_collection.Add Item, Key, Before, After
    End If
End Function

Private Function NextInternalKey() As String
    Dim n As String
    
    n = INTERNAL_KEY_SIGNATURE & CStr(Int(4294967296# * Rnd - 2147483648#)) & CStr(Int(4294967296# * Rnd - 2147483648#))

    If HasKey(n) Then
        NextInternalKey = NextInternalKey()
    Else
        NextInternalKey = n
    End If
End Function

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

Public Sub Remove(Key As Variant)
    Dim k As Variant
    k = m_indexes(Key)
    
    m_items.Remove k
    m_indexes.Remove Key
    m_keys.Remove k
End Sub

Public Property Get Items() As Collection
    Dim c As New Collection
    Dim k As Variant
    
    For Each k In m_indexes
        If CollectionHasKey(m_keys, k) Then
            c.Add m_items(k), m_keys(k)
        Else
            c.Add m_items(k)
        End If
    Next

    Set Items = c
End Property

Public Property Get Keys() As Collection
    Dim c As New Collection
    Dim Key As Variant
    
    For Each Key In m_keys
        c.Add Key
    Next

    Set Keys = c
End Property

Public Function Exists(Item As Variant) As Boolean
    Dim match As Boolean
    Dim v As Variant

    For Each v In m_items
        Select Case VarType(v)
            Case vbEmpty
                match = VarType(Item) = vbEmpty
                
            Case vbNull
                match = VarType(Item) = vbNull
                
            Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
                If IsNumeric(Item) Then
                    match = v = Item
                End If
                
            Case vbDate
                If VarType(Item) = vbDate Then
                    match = v = Item
                End If
                
            Case vbString
                If VarType(Item) = vbString Then
                    match = v = Item
                End If
                
            Case vbObject
                If VarType(Item) = vbObject Then
                    match = v Is Item
                End If
    
            Case vbBoolean
                If VarType(Item) = vbBoolean Then
                    match = v = Item
                End If

            ' vbError, vbVariant, vbDataObject, vbUserDefinedType, vbArray
            Case Else
                Err.Raise 3169
                
        End Select
        
        If match Then
            Exit For
        End If
    Next

    Exists = match
End Function

Public Function HasKey(Key As String) As Boolean
    HasKey = CollectionHasKey(m_indexes, Key)
End Function

Public Function CollectionHasKey(a_collection As Collection, a_Key As Variant) As Boolean
    Dim l As Long
    
    On Error Resume Next
    l = VarType(a_collection(a_Key))
    CollectionHasKey = Err.Number = 0
End Function