Option Explicit '#################################################################################################################### '# # '# Copyright: Volkswagen Aktiengesellschaft 2012 # '# Creator: Henry Schneider (ehenry3) Abteilung: K-SIPE-2/2 # '# Date: 2012-07-17 Version: 0.1.0.0 # '# Autors: Henry Schneider (ehenry3) henry.schneider(at)autovision-gmbh.com # '# Henry Schneider (HoBLila) lila(at)lilashome.de # '# # '# Description: Soll eine Ähnliche Klasse, wie das Scription.Dictionary zur Verfügung stellen. # '# Es handelt sich dabei um ein Array mit Keys, welches Objekte aufnimmt, die man # '# dynamisch hinzufügen und löschen kann. # '# Ich bitte alle, die diese Klasse verbessern, ihre Änderungen auch zu teilen. # '# # '# Changes: # '# # '# License: Copyright (C) 2012 Volkswagen Aktiengesellschaft # '# # '# This program is free software; you can redistribute it and/or modify it under the terms # '# of the GNU General Lesser Public License as published by the Free Software Foundation; # '# either version 3 of the License, or (at your option) any later version. # '# # '# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; # '# without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # '# See the GNU Lesser General Public License for more details. # '# # '# You should have received a copy of the GNU Lesser General Public License along with this program; # '# if not, see . # '# # '#################################################################################################################### Sub CATMain() 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 Sub Class 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 Set arrVarBuffer(lItemAdd) = m_arrVarValues(lItem) 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 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