This class encapsulates a List<KeyValuePair> (see List<T> implementation here, and KeyValuePair implementation here) and exposes a richer set of members than the typical Scripting.Dictionary, ..not to mention the anemic Collection class.
The class enforces some "type safety", in the sense that if you add a KeyValuePair<String, Integer>, then you'll only be allowed to add KeyValuePair<String, Integer> instances, the object will raise an error if you try adding, say, a KeyValuePair<String, Control>, or anything that's not a KeyValuePair<String, Integer>.
The OptionStrict property enables allowing more flexibility and adding a KeyValuePair<String, Byte> to a Dictionary<String, Integer>, for example (but not the opposite).
As with the List<T> implementation, this class uses procedure attributes (not shown) which make the Item property the default property (so myDictionary(i) returns the value at index i), and the NewEnum property enables iterating all values with a For Each loop construct.
Private Type tDictionary
Encapsulated As List
TKey As String
IsRefTypeKey As Boolean
TValue As String
IsRefTypeValue As Boolean
End Type
Private Enum DictionaryErrors
TypeMismatchUnsafeType = vbObjectError + 1001
End Enum
Private this As tDictionary
Option Explicit
Private Sub Class_Initialize()
Set this.Encapsulated = New List
this.Encapsulated.OptionStrict = True
End Sub
Private Sub Class_Terminate()
Set this.Encapsulated = Nothing
End Sub
Public Property Get Count() As Long
Count = this.Encapsulated.Count
End Property
Public Property Get Keys() As List
Dim result As New List
Dim kvp As KeyValuePair
result.OptionStrict = this.Encapsulated.OptionStrict
For Each kvp In this.Encapsulated
result.Add kvp.Key
Next
Set Keys = result
End Property
Public Property Get Values() As List
Dim result As New List
Dim kvp As KeyValuePair
result.OptionStrict = this.Encapsulated.OptionStrict
For Each kvp In this.Encapsulated
result.Add kvp.value
Next
Set Values = result
End Property
Public Property Get OptionStrict() As Boolean
OptionStrict = this.Encapsulated.OptionStrict
End Property
Public Property Let OptionStrict(value As Boolean)
this.Encapsulated.OptionStrict = value
End Property
Private Function ToKeyValuePair(k As Variant, v As Variant) As KeyValuePair
Dim result As New KeyValuePair
If IsObject(k) Then
Set result.Key = k
Else
result.Key = k
End If
If IsObject(v) Then
Set result.value = v
Else
result.value = v
End If
Set ToKeyValuePair = result
End Function
Public Property Get Item(k As Variant) As Variant
Dim i As Long
i = Keys.IndexOf(k)
If i = -1 Then Err.Raise 9 'index out of range
If this.IsRefTypeValue Then
Set Item = Values(i)
Else
Item = Values(i)
End If
End Property
Public Property Set Item(k As Variant, v As Variant)
Dim kvp As KeyValuePair
Dim i As Long
i = Keys.IndexOf(k)
If i <> -1 Then
Set kvp = ToKeyValuePair(k, v)
Set this.Encapsulated(i) = kvp
Else
Add k, v
End If
End Property
Public Property Let Item(k As Variant, v As Variant)
Dim kvp As KeyValuePair
Dim i As Long
i = Keys.IndexOf(k)
If i <> -1 Then
Set kvp = ToKeyValuePair(k, v)
Set this.Encapsulated(i) = kvp
Else
Add k, v
End If
End Property
Public Sub Add(k As Variant, v As Variant)
Dim kvp As KeyValuePair
Set kvp = ToKeyValuePair(k, v)
If Keys.Contains(k) Then Err.Raise 457 'key already exists
If ValidateItemType(kvp, ThrowOnUnsafeType:=True) Then this.Encapsulated.Add kvp
End Sub
Private Function ValidateItemType(kvp As KeyValuePair, Optional ThrowOnUnsafeType As Boolean = False) As Boolean
If this.TKey = vbNullString And this.TValue = vbNullString Then
this.TKey = TypeName(kvp.Key)
this.IsRefTypeKey = IsObject(kvp.Key)
this.TValue = TypeName(kvp.value)
this.IsRefTypeValue = IsObject(kvp.value)
End If
ValidateItemType = IsTypeSafe(kvp)
If ThrowOnUnsafeType And Not ValidateItemType Then RaiseErrorUnsafeType "ValidateItemType()", kvp.ToString
End Function
Public Function IsTypeSafe(kvp As KeyValuePair) As Boolean
'Determines whether a value can be safely added to the List.
IsTypeSafe = (this.TKey = vbNullString Or this.TKey = TypeName(kvp.Key)) _
And (this.TValue = vbNullString Or this.TValue = TypeName(kvp.value))
If IsTypeSafe Then Exit Function
Select Case this.TKey
Case "String":
IsTypeSafe = IsSafeKeyString(kvp.Key)
If IsTypeSafe Then kvp.Key = CStr(kvp.Key)
Case "Boolean"
IsTypeSafe = IsSafeKeyBoolean(kvp.Key)
If IsTypeSafe Then kvp.Key = CBool(kvp.Key)
Case "Byte":
IsTypeSafe = IsSafeKeyByte(kvp.Key)
If IsTypeSafe Then kvp.Key = CByte(kvp.Key)
Case "Date":
IsTypeSafe = IsSafeKeyDate(kvp.Key)
If IsTypeSafe Then kvp.Key = CDate(kvp.Key)
Case "Integer":
IsTypeSafe = IsSafeKeyInteger(kvp.Key)
If IsTypeSafe Then kvp.Key = CInt(kvp.Key)
Case "Long":
IsTypeSafe = IsSafeKeyLong(kvp.Key)
If IsTypeSafe Then kvp.Key = CLng(kvp.Key)
Case "Single"
IsTypeSafe = IsSafeKeySingle(kvp.Key)
If IsTypeSafe Then kvp.Key = CSng(kvp.Key)
Case "Double":
IsTypeSafe = IsSafeKeyDouble(kvp.Key)
If IsTypeSafe Then kvp.Key = CDbl(kvp.Key)
Case "Currency":
IsTypeSafe = IsSafeKeyCurrency(kvp.Key)
If IsTypeSafe Then kvp.Key = CCur(kvp.Key)
Case Else:
IsTypeSafe = False
End Select
If Not IsTypeSafe Then Exit Function
Select Case this.TValue
Case "String":
IsTypeSafe = IsSafeValueString(kvp.value)
If IsTypeSafe Then kvp.value = CStr(kvp.value)
Case "Boolean"
IsTypeSafe = IsSafeValueBoolean(kvp.value)
If IsTypeSafe Then kvp.value = CBool(kvp.value)
Case "Byte":
IsTypeSafe = IsSafeValueByte(kvp.value)
If IsTypeSafe Then kvp.value = CByte(kvp.value)
Case "Date":
IsTypeSafe = IsSafeValueDate(kvp.value)
If IsTypeSafe Then kvp.value = CDate(kvp.value)
Case "Integer":
IsTypeSafe = IsSafeValueInteger(kvp.value)
If IsTypeSafe Then kvp.value = CInt(kvp.value)
Case "Long":
IsTypeSafe = IsSafeValueLong(kvp.value)
If IsTypeSafe Then kvp.value = CLng(kvp.value)
Case "Single"
IsTypeSafe = IsSafeValueSingle(kvp.value)
If IsTypeSafe Then kvp.value = CSng(kvp.value)
Case "Double":
IsTypeSafe = IsSafeValueDouble(kvp.value)
If IsTypeSafe Then kvp.value = CDbl(kvp.value)
Case "Currency":
IsTypeSafe = IsSafeValueCurrency(kvp.value)
If IsTypeSafe Then kvp.value = CCur(kvp.value)
Case Else:
IsTypeSafe = False
End Select
ErrHandler:
'swallow overflow errors:
If Err.number = 6 Then
Err.Clear
Resume Next
ElseIf Err.number <> 0 Then
RaiseErrorUnsafeType "IsTypeSafe()", kvp.ToString
End If
End Function
Private Function IsSafeKeyString(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyString = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyString Or OptionStrict Then Exit Function
Dim result As Boolean
result = CStr(value)
IsSafeKeyString = (Err.number = 0)
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyDate(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyDate = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyDate Or OptionStrict Then Exit Function
Dim result As Boolean
result = CDate(value)
IsSafeKeyDate = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyDate(" & CStr(Value) & ") : " & IsSafeKeyDate
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyByte(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyByte = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyByte Or OptionStrict Then Exit Function
Dim result As Boolean
result = CByte(value)
IsSafeKeyByte = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyByte(" & CStr(Value) & ") : " & IsSafeKeyByte
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyBoolean(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyBoolean = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyBoolean Or OptionStrict Then Exit Function
Dim result As Boolean
result = CBool(value)
IsSafeKeyBoolean = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyBoolean(" & CStr(Value) & ") : " & IsSafeKeyBoolean
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyCurrency(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyCurrency = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyCurrency Or OptionStrict Then Exit Function
Dim result As Boolean
result = CCur(value)
IsSafeKeyCurrency = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyCurrency(" & CStr(Value) & ") : " & IsSafeKeyCurrency
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyInteger(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyInteger = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyInteger Or OptionStrict Then Exit Function
Dim result As Boolean
result = CInt(value)
IsSafeKeyInteger = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyInteger(" & CStr(Value) & ") : " & IsSafeKeyInteger
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyLong(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyLong = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyLong Or OptionStrict Then Exit Function
Dim result As Boolean
result = CLng(value)
IsSafeKeyLong = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyLong(" & CStr(Value) & ") : " & IsSafeKeyLong
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeyDouble(value As Variant) As Boolean
On Error Resume Next
IsSafeKeyDouble = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeyDouble Or OptionStrict Then Exit Function
Dim result As Boolean
result = CDbl(value)
IsSafeKeyDouble = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeyDouble(" & CStr(Value) & ") : " & IsSafeKeyDouble
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeKeySingle(value As Variant) As Boolean
On Error Resume Next
IsSafeKeySingle = (this.TKey = vbNullString Or this.TKey = TypeName(value))
If IsSafeKeySingle Or OptionStrict Then Exit Function
Dim result As Boolean
result = CSng(value)
IsSafeKeySingle = (Err.number = 0)
'If this.OptionTrace And IsSafeKeyString(Value) Then Debug.Print "TRACE: IsSafeKeySingle(" & CStr(Value) & ") : " & IsSafeKeySingle
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueString(value As Variant) As Boolean
On Error Resume Next
IsSafeValueString = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueString Or OptionStrict Then Exit Function
Dim result As Boolean
result = CStr(value)
IsSafeValueString = (Err.number = 0)
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueDate(value As Variant) As Boolean
On Error Resume Next
IsSafeValueDate = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueDate Or OptionStrict Then Exit Function
Dim result As Boolean
result = CDate(value)
IsSafeValueDate = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueDate(" & CStr(Value) & ") : " & IsSafeValueDate
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueByte(value As Variant) As Boolean
On Error Resume Next
IsSafeValueByte = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueByte Or OptionStrict Then Exit Function
Dim result As Boolean
result = CByte(value)
IsSafeValueByte = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueByte(" & CStr(Value) & ") : " & IsSafeValueByte
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueBoolean(value As Variant) As Boolean
On Error Resume Next
IsSafeValueBoolean = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueBoolean Or OptionStrict Then Exit Function
Dim result As Boolean
result = CBool(value)
IsSafeValueBoolean = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueBoolean(" & CStr(Value) & ") : " & IsSafeValueBoolean
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueCurrency(value As Variant) As Boolean
On Error Resume Next
IsSafeValueCurrency = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueCurrency Or OptionStrict Then Exit Function
Dim result As Boolean
result = CCur(value)
IsSafeValueCurrency = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueCurrency(" & CStr(Value) & ") : " & IsSafeValueCurrency
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueInteger(value As Variant) As Boolean
On Error Resume Next
IsSafeValueInteger = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueInteger Or OptionStrict Then Exit Function
Dim result As Boolean
result = CInt(value)
IsSafeValueInteger = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueInteger(" & CStr(Value) & ") : " & IsSafeValueInteger
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueLong(value As Variant) As Boolean
On Error Resume Next
IsSafeValueLong = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueLong Or OptionStrict Then Exit Function
Dim result As Boolean
result = CLng(value)
IsSafeValueLong = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueLong(" & CStr(Value) & ") : " & IsSafeValueLong
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueDouble(value As Variant) As Boolean
On Error Resume Next
IsSafeValueDouble = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueDouble Or OptionStrict Then Exit Function
Dim result As Boolean
result = CDbl(value)
IsSafeValueDouble = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueDouble(" & CStr(Value) & ") : " & IsSafeValueDouble
Err.Clear
On Error GoTo 0
End Function
Private Function IsSafeValueSingle(value As Variant) As Boolean
On Error Resume Next
IsSafeValueSingle = (this.TValue = vbNullString Or this.TValue = TypeName(value))
If IsSafeValueSingle Or OptionStrict Then Exit Function
Dim result As Boolean
result = CSng(value)
IsSafeValueSingle = (Err.number = 0)
'If this.OptionTrace And IsSafeValueString(Value) Then Debug.Print "TRACE: IsSafeValueSingle(" & CStr(Value) & ") : " & IsSafeValueSingle
Err.Clear
On Error GoTo 0
End Function
Private Sub RaiseErrorUnsafeType(member As String, suppliedType As String)
Err.Raise DictionaryErrors.TypeMismatchUnsafeType, _
StringFormat("{0}.{1}", ToString, member), _
StringFormat("Type Mismatch. Expected: 'KeyValuePair<{0},{1}>', '{2}' was supplied.", this.TKey, this.TValue, suppliedType)
End Sub
Public Sub Clear()
this.Encapsulated.Clear
End Sub
Public Function Contains(v As Variant) As Boolean
Contains = Values.Contains(v)
End Function
Public Function ContainsKey(k As Variant) As Boolean
ContainsKey = Keys.Contains(k)
End Function
Public Property Get NewEnum() As IUnknown
'Gets an enumerator that iterates through the values held in the Dictionary.
Set NewEnum = this.Encapsulated.NewEnum
End Property
Public Function Remove(v As Variant) As Boolean
Dim i As Long
i = Values.IndexOf(v)
If i <> -1 Then
this.Encapsulated.RemoveAt i
Remove = True
Else
Remove = False
End If
End Function
Public Function RemoveKey(k As Variant) As Boolean
Dim i As Long
i = Keys.IndexOf(k)
If i <> -1 Then
this.Encapsulated.RemoveAt i
RemoveKey = True
Else
RemoveKey = False
End If
End Function
Public Function TryGetValue(k As Variant, ByRef outValue As Variant) As Boolean
Dim i As Long
i = Keys.IndexOf(k)
Dim kvp As KeyValuePair
If i <> -1 Then
Set kvp = this.Encapsulated(i)
If IsObject(kvp.value) Then
Set outValue = kvp.value
Else
outValue = kvp.value
End If
TryGetValue = True
Else
TryGetValue = False
End If
End Function
Public Function ToList() As List
Set ToList = this.Encapsulated
End Function
Public Function ToString() As String
ToString = TypeName(Me) & "<" & IIf(this.TKey = vbNullString, "Variant", this.TKey) & ", " & IIf(this.TValue = vbNullString, "Variant", this.TValue) & ">"
End Function
I've written this a little while ago, in the mean time I've learned about CallByName, so now I wonder if there wouldn't be a really clever way to rework the IsTypeSafe method so as to avoid the Select Case blocks (CallByName doesn't seem to work for functions / methods with a return value).
