Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement