Code:
Sub CATMain()
Dim New_MyDictionary
Dim cars 'As New MyDictionary
Set cars = New_MyDictionary
Call cars.add("a", "Alvis")
Call cars.add("b", "Buick")
Call cars.add("c", "Cadillac")
MsgBox "The value corresponding to the key 'b' is " & cars.item("b")
End SubClass MyDictionary
Private m_arrSKeys() 'As String ' Liste der benutzten Keys
Private m_arrVarValues() 'As Variant ' Liste der zugeordneten Objekte
Private m_lCount 'As Long ' Anzahl enthaltender Elemente
' Konstruktor
Private Sub Class_Initialize()
m_lCount = 0
End Sub
' Methode zum Hinzufügen von neuen Elementen
Public Function add(ByVal i_sKey, ByRef i_varValue) '(ByVal i_sKey As String, ByRef i_varValue As Variant) As Boolean
add = False
' Wenn Key schon existiert, dann raus
If (Me.exists(i_sKey) = True) Then Exit Function
' Arrays um eins erweitern
ReDim Preserve m_arrSKeys(m_lCount)
ReDim Preserve m_arrVarValues(m_lCount)
m_arrSKeys(m_lCount) = i_sKey
If (IsObject(i_varValue)) Then
Set m_arrVarValues(m_lCount) = i_varValue
Else
m_arrVarValues(m_lCount) = i_varValue
End If
m_lCount = m_lCount + 1
add = True
End Function
' Methode zum Entfernen von Elementen
' der Key-Name wird übergben
Public Sub remove(ByRef i_sKey) '(ByRef i_sKey As String)
Dim arrSBuffer() 'As String
Dim arrVarBuffer() 'As Variant
Dim lItem 'As Long
Dim lItemAdd 'As Long
Dim lUBound 'As Long
' Wenn Key nicht existiert, dann raus
If (Me.exists(i_sKey) = False) Then Exit Sub
' Anzahl Einträge ermitteln
lUBound = Me.count - 1
' Puffer festlegen
ReDim arrSBuffer(lUBound)
ReDim arrVarBuffer(lUBound)
' Alte-Werte ohne Eintrag in den Puffer schreiben
lItemAdd = 0
For lItem = 0 To lUBound
If (Not m_arrSKeys(lItem) = i_sKey) Then
If (IsObject(m_arrVarValues(lItem))) Then
Set arrVarBuffer(lItemAdd) = m_arrVarValues(lItem)
Else
arrVarBuffer(lItemAdd) = m_arrVarValues(lItem)
End If
arrSBuffer(lItemAdd) = m_arrSKeys(lItem)
lItemAdd = lItemAdd + 1
End If
Next 'lItem
' Puffer in Array-Values zurückschreiben
m_arrVarValues = arrVarBuffer
' Puffer in Array-Values zurückschreiben
m_arrSKeys = arrSBuffer
' Count runterzählen
m_lCount = m_lCount - 1
End Sub
' methode um alle Elemente zu entfernen
Public Sub removeAll()
m_lCount = 0
' On Error Resume Next
' ReDim m_arrSKeys(-1)
' ReDim m_arrVarValues(-1)
' On Error GoTo 0
Erase m_arrSKeys
Erase m_arrVarValues
End Sub
' Methode um zu überprüfen ob ein Key bereits existiert
Public Function exists(ByRef i_sKeyName) '(ByRef i_sKeyName As String) As Boolean
Dim varSKeyWork 'As Variant
exists = False
If (Me.count > 0) Then
For Each varSKeyWork In m_arrSKeys
If (varSKeyWork = i_sKeyName) Then
exists = True
Exit For
End If
Next 'varSKeyWork
End If
End Function
' Methode um die Anzahl der Elemente zu ermitteln
Public Property Get count() 'As Long
' On Error Resume Next
' count = UBound(m_arrSKeys)
' If (Not Err.Number = 0) Then count = 0
' On Error GoTo 0
count = m_lCount
End Property
' Methode um ein Element, dessen Key bekannt ist, zu erhalten
Public Function item(ByVal i_sKey) '(ByVal i_sKey As String) As Variant
Dim lCount 'As Long
Dim lItem 'As Long
item = vbNullString
lCount = Me.count
If (lCount > 0) Then
For lItem = 0 To lCount - 1
If (i_sKey = m_arrSKeys(lItem)) Then
item = m_arrVarValues(lItem)
Exit For
End If
Next 'lItem
End If
End Function
' Methode um ein Element, dessen Nummer bekannt ist, zu erhalten
Public Function itemByNumber(ByVal i_lItem) '(ByVal i_lItem As Long) As Variant
If (i_lItem <= m_lCount) Then
Set itemByNumber = m_arrVarValues(i_lItem)
Else
Set itemByNumber = Nothing
End If
End Function
' Methode um den Namen eines Keys zu ändern
Public Function changeKeyName(ByRef i_sOldKeyName, ByRef i_sNewKeyName) '(ByRef i_sOldKeyName As String, ByRef i_sNewKeyName As String) As Boolean
changeKeyName = False
If (Me.exists(i_sNewKeyName)) Then Exit Function
Dim lCount 'As Long
Dim lItem 'As Long
item = vbNullString
lCount = Me.count
If (lCount > 0) Then
For lItem = 0 To lCount - 1
If (i_sOldKeyName = m_arrSKeys(lItem)) Then
m_arrSKeys(lItem) = i_sOldKeyName
changeKeyName = True
Exit For
End If
Next 'lItem
End If
End Function
' Methode um alle Keys, als Liste zu erhalten
Public Function keys() 'As String()
keys = m_arrSKeys
End Function
' Methode um alle Items, als Liste zu erhalten
Public Function items() 'As Variant()
items = m_arrVarValues
End Function
Private Sub Class_Terminate()
Erase m_arrSKeys
Erase m_arrVarValues
End Sub
End Class