Here we go, a pretty fast key collection class for cross referencing keys, item values and collection indexes:
Code:
' KeyCollection.cls
Option Explicit
Private Type IndexInformation
Pos As Long
Value As Long
End Type
Private m_Index() As IndexInformation
Private m_Keys As String
Public Function Add(ByVal Item As Long, ByRef Key As String) As Long
' must have key
If LenB(Key) Then
' must not exist
If InStr(m_Keys, vbNullChar & Key & vbNullChar) = 0 Then
' yay, add it!
Add = UBound(m_Index) + 1
' space for it
ReDim Preserve m_Index(Add)
' remember key position
With m_Index(Add)
.Pos = Len(m_Keys) + 1
.Value = Item
End With
' add to our key string
m_Keys = m_Keys & (Key & vbNullChar)
Exit Function
Else
' uncomment if you want an error if the item exists
'Err.Raise 5, "KeyCollection.Add", "Key already exists."
End If
Else
' uncomment if you want an error if the key is invalid
'Err.Raise 5, "KeyCollection.Add", "Invalid key."
End If
End Function
Public Function Count() As Long
' this is straightforward
Count = UBound(m_Index)
End Function
Public Function Item(ByRef Key As String) As Long
Dim lngA As Long, lngPos As Long
' must have key
If LenB(Key) Then
' find position
lngPos = InStr(m_Keys, vbNullChar & Key & vbNullChar) + 1
' do we have it?
If lngPos > 1 Then
' now we just have to find which item it is
For lngA = 1 To UBound(m_Index)
With m_Index(lngA)
' it is more likely to not have a match: True condition is faster
If .Pos <> lngPos Then
' not found
Else
' found!
Item = .Value
Exit Function
End If
End With
Next lngA
' uncomment if you want to know about this critical error
'Err.Raise 5, "KeyCollection.Item", "Key not found yet key exists!"
Else
' uncomment if you want an error if the key doesn't exist
'Err.Raise 5, "KeyCollection.Item", "Key does not exist."
End If
Else
' uncomment if you want an error if the key is invalid
'Err.Raise 5, "KeyCollection.Item", "Invalid key."
End If
End Function
Public Function Key(ByVal Item As Long) As String
Dim lngA As Long, lngPos As Long
For lngA = 1 To UBound(m_Index)
With m_Index(lngA)
If .Value <> Item Then
' not found
Else
' get the key for this index
lngPos = InStr(.Pos, m_Keys, vbNullChar)
If lngPos > 1 Then
' return it
Key = Mid$(m_Keys, .Pos, lngPos - .Pos)
Exit Function
Else
' uncomment if you want this critical error
'Err.Raise 5, "KeyCollection.Key", "Key string not found!"
End If
End If
End With
Next lngA
' uncomment if you want an error if the key doesn't exist
'Err.Raise 5, "KeyCollection.Key", "Item value not found."
End Function
Public Function KeyByIndex(ByVal Index As Long) As String
Dim lngPos As Long
' validate range
If Index >= 1 And Index <= UBound(m_Index) Then
With m_Index(Index)
' get the key for this index
lngPos = InStr(.Pos, m_Keys, vbNullChar)
If lngPos > 1 Then
' return it
KeyByIndex = Mid$(m_Keys, .Pos, lngPos - .Pos)
Exit Function
Else
' uncomment if you want this critical error
'Err.Raise 5, "KeyCollection.KeyByIndex", "Key string not found!"
End If
End With
Else
' uncomment if you want an error if the index is invalid
'Err.Raise 5, "KeyCollection.KeyByIndex", "Invalid."
End If
End Function
Public Function Remove(ByRef Key As String) As Boolean
Dim lngA As Long, lngB As Long, lngPos As Long, lngLen As Long
' must have key
If LenB(Key) Then
' find position
lngPos = InStr(m_Keys, vbNullChar & Key & vbNullChar) + 1
' do we have it?
If lngPos > 1 Then
' now we just have to find which item it is
For lngA = 1 To UBound(m_Index)
' it is more likely to not have a match: True condition is faster
If m_Index(lngA).Pos <> lngPos Then
' not found
Else
' found, start removal
lngLen = Len(Key) + 1
' copy information
For lngB = lngA To UBound(m_Index) - 1
m_Index(lngB).Pos = m_Index(lngB + 1).Pos - lngLen
m_Index(lngB).Value = m_Index(lngB + 1).Value
Next lngB
' free memory
ReDim Preserve m_Index(lngB - 1)
' now, remove the key
m_Keys = Left$(m_Keys, lngPos - 1) & Mid$(m_Keys, lngPos + lngLen)
' success!
Remove = True
Exit Function
End If
Next lngA
' uncomment if you want to know about this critical error
'Err.Raise 5, "KeyCollection.Item", "Key not found yet key exists!"
Else
' uncomment if you want an error if the key doesn't exist
'Err.Raise 5, "KeyCollection.Item", "Key does not exist."
End If
Else
' uncomment if you want an error if the key is invalid
'Err.Raise 5, "KeyCollection.Item", "Invalid key."
End If
End Function
Private Sub Class_Initialize()
m_Keys = vbNullChar
ReDim m_Index(0)
End Sub
Private Sub Class_Terminate()
m_Keys = vbNullString
Erase m_Index
End Sub
Sample:
Code:
Option Explicit
Private Sub Form_Load()
Dim Keys As New KeyCollection
Keys.Add 4, "A"
Keys.Add 3, "B"
Keys.Add 2, "C"
Keys.Add 1, "D"
' make key "D" invalid, index 4 invalid and item 1 invalid
Keys.Remove "D"
' by index "ABC" (note: I have set KeyByIndex as (Default) in Tools > Procedure Attributes)
MsgBox Keys(1) & Keys(2) & Keys(3) & Keys(4)
' by key string "4320"
MsgBox Keys.Item("A") & Keys.Item("B") & Keys.Item("C") & Keys.Item("D")
' by item "CBA"
MsgBox Keys.Key(1) & Keys.Key(2) & Keys.Key(3) & Keys.Key(4)
End Sub
Class also attached. Tell me if you find any problems in it Uncomment error lines if you want Collection style errors.
Uncomment error lines if you want Collection style errors.
Reply With Quote