7
\$\begingroup\$

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).

\$\endgroup\$
4
\$\begingroup\$

Although CallByName doesn't seem to have a return value (from the parameter tooltip), it does. This means if IsSafeKeyXxxxxx methods were Public you could use CallByName instead of the Select..Case block.

However exposing all these methods through your Dictionary interface would be rather ugly. How about extracting all these small methods into their own TypeValidator class?

Private Type tValueTypeValidator
    TValue As String
    OptionStrict As Boolean
End Type

Private this As tValueTypeValidator
Option Explicit

Public Property Get TValue() As String
    TValue = this.TValue
End Property

Public Property Let TValue(ByVal value As String)
    this.TValue = value
End Property

Public Property Get OptionStrict() As Boolean
    OptionStrict = this.OptionStrict
End Property

Public Property Let OptionStrict(ByVal value As Boolean)
    this.OptionStrict = value
End Property

Public Function ToString() As String
    ToString = TypeName(Me) & "<" & this.TValue & ">"
End Function

Public Function IsSafeBoolean(value As Variant) As Boolean
    On Error Resume Next

    IsSafeBoolean = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeBoolean Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CBool(value)
    IsSafeBoolean = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeByte(value As Variant) As Boolean
    On Error Resume Next

    IsSafeByte = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeByte Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CByte(value)
    IsSafeByte = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeCurrency(value As Variant) As Boolean
    On Error Resume Next

    IsSafeCurrency = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeCurrency Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CCur(value)
    IsSafeCurrency = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeDate(value As Variant) As Boolean
    On Error Resume Next

    IsSafeDate = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeDate Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CDate(value)
    IsSafeDate = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeDouble(value As Variant) As Boolean
    On Error Resume Next

    IsSafeDouble = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeDouble Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CDbl(value)
    IsSafeDouble = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeInteger(value As Variant) As Boolean
    On Error Resume Next

    IsSafeInteger = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeInteger Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CInt(value)
    IsSafeInteger = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeLong(value As Variant) As Boolean
    On Error Resume Next

    IsSafeLong = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeLong Or OptionStrict Then Exit Function

    Dim result As Boolean
    result = CLng(value)
    IsSafeLong = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeSingle(value As Variant) As Boolean
    On Error Resume Next

    IsSafeSingle = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeSingle Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CSng(value)
    IsSafeSingle = (Err.Number = 0)

    Err.Clear
    On Error GoTo 0
End Function

Public Function IsSafeString(value As Variant) As Boolean
    On Error Resume Next

    IsSafeString = (this.TValue = vbNullString Or this.TValue = TypeName(value))
    If IsSafeString Or this.OptionStrict Then Exit Function

    Dim result As Boolean
    result = CStr(value)
    IsSafeString = (Err.Number = 0)
    Err.Clear

    On Error GoTo 0
End Function

And since that code was copy-pasted from an existing List class in the first place, there's already a case for reusing that TypeValidator class.

That change would require the ValidateItemType method to be modified as such:

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)
        this.KeyValidator.TValue = this.TKey '<<< here
        this.ValueValidator.TValue = this.TValue '<<< here
    End If

    ValidateItemType = IsTypeSafe(kvp)

    If ThrowOnUnsafeType And Not ValidateItemType Then RaiseErrorUnsafeType "ValidateItemType()", kvp.ToString

End Function

The OptionStrict property setter would have to be affected as well:

Public Property Let OptionStrict(value As Boolean)
    this.Encapsulated.OptionStrict = value
    this.KeyValidator.OptionStrict = value ' <<< here
    this.ValueValidator.OptionStrict = value ' <<< here
End Property

As well as the Class_Initialize method:

Private Sub Class_Initialize()
    Set this.Encapsulated = New List
    Set this.KeyValidator = New TypeValidator ' <<< here
    Set this.ValueValidator = New TypeValidator ' <<< here
    this.Encapsulated.OptionStrict = True
    this.KeyValidator.OptionStrict = True ' <<< here
    this.ValueValidator.OptionStrict = True ' <<< here
End Sub

And of course the private type of this:

Private Type tDictionary
    Encapsulated As List
    TKey As String
    IsRefTypeKey As Boolean
    TValue As String
    IsRefTypeValue As Boolean
    KeyValidator As TypeValidator ' <<< here
    ValueValidator As TypeValidator ' <<< here
End Type

The IsTypeSafe method implementation could then be simplified to this - gone, the Select..Case blocks!

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

    IsTypeSafe = CallByName(this.KeyValidator, "IsSafe" & this.TKey, VbMethod, kvp.key)
    If Not IsTypeSafe Then Exit Function

    IsTypeSafe = CallByName(this.ValueValidator, "IsSafe" & this.TValue, VbMethod, kvp.value)

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

This also leaves you with a much, much cleaner list of members, as a side-effect of separating the type validation concerns into their own class:

Members of Dictionary Members of TypeValidator

Busted! Yes, I work with a French VB6 IDE!

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.