I have for some time been frustrated by the limitations around enumerations in VBA. Googling didn't find anything really simple and comprehensive. So after a bit of head scratching I came up with the following code which provides a neat intellisense based solution for managing enums to allow easy access to:
- member names
- counting members
- enumerating members correctly
- testing if an enum member exists
The code is contained in a Class with a PredeclaredId and the Class Name used was Enums. Most of what I've achieved could have been done by just using a Scripting.Dictionary, but you would not get the intellisense that the code below provides.
Option Explicit
'@PredeclaredId
'@Exposed
Public Enum EnumAction
AsEnum
AsString
AsExists
AsDictionary
AsCount
End Enum
Public Enum TestingEnum
'AsProperty is assigned -1 because it is not included in the backing dictionary
' and we want the enummeration to start at 0 unless defined otherwise
AsProperty = -1
Apples
Oranges
Cars
Lemons
Trees
Giraffes
End Enum
Private Type Enumerations
Testing As Scripting.Dictionary
End Type
Private e As Enumerations
Private Sub Class_Initialize()
If Not Me Is Enums Then
VBA.Err.Raise _
17, _
"Enumerations.ClassInitialize", _
"Class Enums:New'ed Instances of Class Enums are not allowed"
End If
End Sub
Private Sub PopulateTesting()
Set e.Testing = New Scripting.Dictionary
With e.Testing
' Note: AsProperty is not included in the dictionary
.Add Apples, "Apples"
.Add Oranges, "Oranges"
.Add Cars, "Cars"
.Add Lemons, "Lemons"
.Add Trees, "Trees"
.Add Giraffes, "Giraffes"
End With
End Sub
Public Property Get Testing(ByVal ipEnum As TestingEnum, Optional ByVal ipAction As EnumAction = EnumAction.AsEnum) As Variant
If e.Testing Is Nothing Then PopulateTesting
Select Case ipAction
Case EnumAction.AsEnum
Testing = ipEnum
Case EnumAction.AsString
Testing = e.Testing.Item(ipEnum)
Case EnumAction.AsExists
Testing = e.Testing.Exists(ipEnum)
Case EnumAction.AsCount
Testing = e.Testing.Count
Case EnumAction.AsDictionary
Dim myDictionary As Scripting.Dictionary
Set myDictionary = New Scripting.Dictionary
Dim myKey As Variant
For Each myKey In e.Testing
myDictionary.Add myKey, e.Testing.Item(myKey)
Next
Set Testing = myDictionary
End Select
End Property
Usage
Public Sub Test()
Const Bannannas As Long = 42
Debug.Print "Enum value of lemons is 3", Enums.Testing(Lemons)
Debug.Print "String is Lemons", Enums.Testing(Lemons, AsString)
Debug.Print "Bannannas are False", Enums.Testing(Bannannas, AsExists)
' The AsProperty member is the preferred awkwardness
' as it is a 'Foreign' member just used to make the
' intellisense a bit more sensible.
' in practise any enumeration member could be used as
' the count and dictionary cases ignore the input enum.
Debug.Print "Count is 6", Enums.Testing(AsProperty, AsCount)
Dim myKey As Variant
Dim myDictionary As Scripting.Dictionary
Set myDictionary = Enums.Testing(AsProperty, AsDictionary)
For Each myKey In myDictionary
Debug.Print myKey, myDictionary.Item(myKey)
Next
Dim mykeys As Variant
mykeys = Enums.Testing(AsProperty, AsDictionary).Keys
Dim myvalues As Variant
myvalues = Enums.Testing(AsProperty, AsDictionary).Items
Debug.Print "Apples are apples", myDictionary.Item(Enums.Testing(Apples))
myDictionary.Item(Enums.Testing(Apples)) = "Plums"
Debug.Print "Apples are plums", myDictionary.Item(Enums.Testing(Apples))
Debug.Print "Apples are apples", Enums.Testing(Apples, AsString)
End Sub
test output
Enum value of lemons is 3 3
String is Lemons Lemons
Test is False False
Count is 6 6
0 Apples
1 Oranges
2 Cars
3 Lemons
4 Trees
5 Giraffes
Apples are apples Apples
Apples are plums Plums
Apples are apples Apples
There are some awkwardnesses with the code above:
no support for enums as default values for optional parameters
no assignment of enums to constants
a Local variable could be defined with the same name as an enum member but with a non existing, or worse, alternative value to the enumeration member
The use of the 'AsProperty' 'Foreign' member of the enumeration (partially handled by not including that member in the backing scripting.dictionary.
I'd welcome any comments or suggestions for improvements.
3 Answers 3
I think everybody is frustrated with how enumerations are working in VBA. Not the richest language syntax. As @PeterT mentioned in the comments we all just need to "pick our poison".
There is always some functionality around a single Enum and that could be a simple function or a group of related modules/classes. I would not group all the enums inside a single predeclared class or even a standard module. What if you need to reuse the functionality related to an enum inside another project? You would then need to copy the Enums class/module to that separate project and then trim the extra enums isn't it? Or even worse leave all the enums in there because you don't have the time to do the trimming.
On the other hand, there is one good reason I would not wrap each enum in it's own class just for Intellisense. What if I have 50 enums? Should I add 50 classes to a project which is suffering anyway from having a single class per code module and no inheritance? I would not do it but that's just my subjective point of view. It's difficult to navigate a project even with help from Rubberduck (and even worse without) so I try to minimize the number of code modules.
I've used another "poison" over the years and it seemed to serve me well and of course that does not mean it's better than yours, it's just different and works for me.
Before I start, I must say that the AsEnum feature of your code can be removed because something like Enums.Testing(77) will simply return 77. It's like "give me back the value I gave you" kind of thing really.
A different approach
I am using a general wrapper class but it could be a standard module having the same UDT inside. The reason I prefer a class is because I do not want to pass around a UDT ByRef whenever I write the "wrapper functions" (more on that below). Also, I am not using a Dictionary as I usually do not want to be bound to using just Windows and don't want an extra library reference so instead I use 2 collections for mapping.
I have a general class called EnumWrapper with the following code:
Option Explicit
Private Type EnumLists
arrEnum() As Variant
arrText() As Variant
enumToText As Collection
textToEnum As Collection
End Type
Private m_eLists As EnumLists
Public Sub Init(ByRef arrEnum As Variant, ByRef arrText As Variant)
With m_eLists
.arrEnum = arrEnum
.arrText = arrText
'
Set .enumToText = New Collection
Set .textToEnum = New Collection
'
Dim i As Long
Dim textValue As String
Dim enumValue As Long
'
For i = LBound(.arrEnum) To UBound(.arrEnum)
enumValue = .arrEnum(i)
textValue = .arrText(i)
'
.enumToText.Add textValue, CStr(enumValue)
.textToEnum.Add enumValue, textValue
Next i
End With
End Sub
Public Function Count() As Long
Count = m_eLists.enumToText.Count
End Function
Public Function Exists(ByVal enumValue As Long) As Boolean
On Error Resume Next
m_eLists.enumToText.Item CStr(enumValue)
Exists = (Err.Number = 0)
On Error GoTo 0
End Function
Public Function FromString(ByVal textValue As String _
, Optional ByVal valueIfNotFound As Long) As Long
On Error Resume Next
FromString = m_eLists.textToEnum(textValue)
If Err.Number <> 0 Then FromString = valueIfNotFound
On Error GoTo 0
End Function
Public Function Items() As Variant()
Items = m_eLists.arrEnum
End Function
Public Function Self() As EnumWrapper
Set Self = Me
End Function
Public Function Texts() As Variant()
Texts = m_eLists.arrText
End Function
Public Function ToString(ByVal enumValue As Long _
, Optional ByVal valueIfNotFound As String) As String
On Error Resume Next
ToString = m_eLists.enumToText(CStr(enumValue))
If Err.Number <> 0 Then ToString = valueIfNotFound
On Error GoTo 0
End Function
We could write more code for validation and raising errors in the Init method but I kept it simple for the purpose of this answer.
I then proceed to wrap an instance of this class for each enum that I need so I get the proper Intellisense. For example for your TestingEnum I would do the following wherever the enum is actually placed (class/document/standard module - doesn't really matter):
Option Explicit
Public Enum TestingEnum
InvalidValue = -1
Apples
Oranges
Cars
Lemons
Trees
Giraffes
End Enum
Private Function GetTestingWrapper() As EnumWrapper
Static eWrapper As EnumWrapper
'
If eWrapper Is Nothing Then
Set eWrapper = New EnumWrapper
eWrapper.Init Array(Apples, Oranges, Cars, Lemons, Trees, Giraffes) _
, Array("Apples", "Oranges", "Cars", "Lemons", "Trees", "Giraffes")
End If
Set GetTestingWrapper = eWrapper
End Function
Public Function TestingEnumToString(ByVal enumValue As TestingEnum) As String
TestingEnumToString = GetTestingWrapper.ToString(enumValue) 'Could use optional parameter to return specific string on failure
End Function
Public Function TestingEnumFromString(ByVal textValue As String) As TestingEnum
TestingEnumFromString = GetTestingWrapper.FromString(textValue, InvalidValue)
End Function
Public Function TestingEnumExists(ByVal enumValue As TestingEnum) As Boolean
TestingEnumExists = GetTestingWrapper.Exists(enumValue)
End Function
Public Function TestingEnumCount() As Long
TestingEnumCount = GetTestingWrapper.Count
End Function
Public Function TestingEnumItems() As Variant()
TestingEnumItems = GetTestingWrapper.Items
End Function
Public Function TestingEnumTexts() As Variant()
TestingEnumTexts = GetTestingWrapper.Texts
End Function
Typing TestingEnum would make the Intellisense look like this:
enter image description here
All methods are easy to find and can't really forget their names as they all start with the enum name.
An example of method call:
enter image description here
Of course, sometimes you don't need all of these "wrapper" methods so you would just write the ones you need which helps minimize the bloating.
Your tests would then become:
Option Explicit
Public Sub Test()
Const Bannannas As Long = 42
Debug.Print "Enum value of lemons is 3", TestingEnumFromString("Lemons")
Debug.Print "String is Lemons", TestingEnumToString(Lemons)
Debug.Print "Bannannas are False", TestingEnumExists(Bannannas)
Debug.Print "Count is 6", TestingEnumCount()
Dim myEnumValue As Variant
For Each myEnumValue In TestingEnumItems()
Debug.Print myEnumValue, TestingEnumToString(myEnumValue)
Next
Dim myEnums As Variant
myEnums = TestingEnumItems()
Dim myTexts As Variant
myTexts = TestingEnumTexts()
Debug.Print "Apples are apples", TestingEnumToString(Apples)
End Sub
I removed the "replace apples with plums" part as I don't see the point of that. The purpose of an Enum is to be "constant". If there is a need to change the texts that should happen in the GetTestingWrapper method and of course those values could come from a different source (like a table).
Of course this approach is bloating the global namespace but I can live with that as long as I gain the advantage of placing the code for each enum in the module/class where it actually belongs along other related functionality and this helps with portability with the downside that I also need to carry the EnumWrapper class module.
The bloating would happen anyway even if you were to add all enums to a single class or a separate class per enum because you still need the Intellisense at least for the ToString, FromString and Exists methods. Less true for the Count, Items and Texts methods but this is just part of this approach.
Having 3 lines of code for each "wrapper" method (out of which one is the function definition and one is End Function) is not really a big deal and overall seems cleaner to my subjective view.
-
\$\begingroup\$ "Before I start, I must say that the AsEnum feature of your code can be removed because something like Enums.Testing(77) will simply return 77. It's like "give me back the value I gave you" kind of thing really." You really are missing the point with this comment. The whole point of this function, is that the intellisense for the enumeration is presented as an option at the dot rather than as a separate entity somewhere in VBA unnamespaceland. \$\endgroup\$Freeflow– Freeflow2021年08月16日 18:13:49 +00:00Commented Aug 16, 2021 at 18:13
-
\$\begingroup\$ @Freeflow So, let me get this straight. If the action is
AsEnumthen your method returnsTesting = ipEnumthe same value being passed. This is what I was reffering to. SinceAsEnumis 0 thenTesting(77)is the same asTesting(77,AsEnum)which returns 77. This simply returns the value you pass. I see there is Intellinsense. But for what? Why do you need a function that returns the value you pass in? I expressed exactly what I wanted to say. Again, I am only referring when the action is set toAsEnum. I can see howAsStringand the others are useful. \$\endgroup\$Cristian Buse– Cristian Buse2021年08月17日 06:26:44 +00:00Commented Aug 17, 2021 at 6:26 -
\$\begingroup\$ @Freeflow It only clicked with me now what you meant by Intellisense. Why would you use
Testing(...,AsEnum)to get the Intellisense instead of simply typing the name of the Enum and then the dot like inTestingEnum.. Second one is much cleaner and it's like calling a constant instead of unnecesarilly running a method that returns the value you pass in. \$\endgroup\$Cristian Buse– Cristian Buse2021年08月17日 06:39:39 +00:00Commented Aug 17, 2021 at 6:39 -
\$\begingroup\$ Things have probably got slightly confused by now compared to the original implementation. For Enumerations, they are not visible in the VBA Ide project explorer so you need to look at source code to discover them. Once you know the name then as you say you can just use enumerationname.membername. However, the AsEnum public method means that for an object, you get AsEnum listed as a method and then a list of the enum members. Additionally if you are offering other options, such as toString, IsMember etc then asenum quite clearly states what you are getting. \$\endgroup\$Freeflow– Freeflow2021年08月17日 11:56:27 +00:00Commented Aug 17, 2021 at 11:56
-
\$\begingroup\$ @Freeflow Makes more sense now. Yes, you cannot see an Enum in the Project Explorer but if you have too many enums then it would be overkill to make one Predeclared Class for each. The project would get really cluttered. On the other hand, combining all enums into a single class will hurt your project when it comes to portability and not to mention that unrelated enums will become tightly coupled (along with their related functionality). I think you must decide the best approach by having the long-term maintainability and support of the project in mind and that might as well be your approach. \$\endgroup\$Cristian Buse– Cristian Buse2021年08月17日 12:16:38 +00:00Commented Aug 17, 2021 at 12:16
Some thought in no particular order:
Could the Enums predeclared Class be a standard module? That would avoid the need to have this check:
Private Sub Class_Initialize() If Not Me Is Enums Then VBA.Err.Raise _ 17, _ "Enumerations.ClassInitialize", _ "Class Enums:New'ed Instances of Class Enums are not allowed" End If End Sub
And would make prepending Enums optional. The downside would be PopulateTesting isn't automatically called (I assume you meant to call it in Class_Initialize), but you can call it upon first invocation of Public Property Get Testing which would save a hit at runtime if you have many enums to populate but only a few are actually required. edit: in your updated code I see you've gone with the lazy populate option
Incidentally if we're being perfectionists, I would rather see this above code written as a named guard clause - and why magic 17?
Private Type Enumerations Testing As Scripting.Dictionary End Type Private e As Enumerations
Why is this module level? If I add a second enum, why does it need to know about the e.Testing dictionary? I'd use a Static variable inside the sub.
Also I'd probably rename e.Testing to this.TestingMap or even this.TestingNamesFromEnumValues.
There's a lot of boilerplate adding a new Enum to this class, particularly this big select case block:
Select Case ipAction Case EnumAction.AsEnum Testing = ipEnum Case EnumAction.AsString Testing = e.Testing.Item(ipEnum) Case EnumAction.AsExists Testing = e.Testing.Exists(ipEnum) Case EnumAction.AsCount Testing = e.Testing.Count Case EnumAction.AsDictionary Dim myDictionary As Scripting.Dictionary Set myDictionary = New Scripting.Dictionary Dim myKey As Variant For Each myKey In e.Testing myDictionary.Add myKey, e.Testing.Item(myKey) Next Set Testing = myDictionary End Select
... wouldn't want to write that out too many times! This could be extracted into a private function which takes the dictionary/ enum name as a parameter - maybe the class stores a collection of enumName:lookupDictionary pairs rather than hard coding them in a UDT.
The EnumAction stuff is kinda weird, I see why you've done it but honestly these actions are just begging to be methods of a class.
I think another approach here would be to have 1 class for each enum, maybe even predeclared and shadowing the enum name, although a strongly typed member of a global collection could be a neater API (so a property get Testing() As TestingEnum). You can then just write some helper functions for letting these classes register their members somewhere, quickly look them up or look up properties about them, and then the enum classes can use these to implement the actions you want without repeating too much boilerplate. For standard methods like Count or AsDictionary, your Enum objects could implement a standard interface, perhaps with an easy accessor for the interface:
Interface: IEnum
Public Property Get Count() As Long
Public Function AsDictionary() As Dictionary
Class: TestingEnum
Public Property Get Info() As IEnum
Set Info = Me
End Property
then you can do TestingEnum.Info.Count for example. Or a caller can cast to IEnum and call .Count themselves. You get the idea.
Scripting.Dictionary doesn't expose an IEnumVariant member like Collections do, but you could expose a generator function to allow your enums to be used in a for each loop
Public Enum TestingEnum 'AsProperty is assigned -1 because it is not included in the backing dictionary ' and we want the enummeration to start at 0 unless defined otherwise AsProperty = -1 Apples Oranges Cars Lemons Trees Giraffes End Enum
I would expose a constant from your class so users know -1 isn't a hard requirement:
Public Const AsPropertyEnumValue As Long = -1 'or anything really
'...
Public Enum TestingEnum
AsProperty = AsPropertyEnumValue
Having a default 0 starting position is a weird requirement I think you should scrap, if the user wants Apples to be 0, they should set it to zero. Abstracting away the implementation of this AsProperty member will encourage the user not to assume any particular starting value.
If you switch to methods defined in an interface rather than by this Action parameter then the AsProperty member can be removed or made [_hidden] as an implementation detail.
Since VBA/VB6 treats Enums as Longs under the hood, so I suggest a generic wrapper to which you can supply your Enums and their string representations. This way you avoid having to have a separate class for each one.
Let's start with a generic class that serves a two-way or "bi-directional" map, which I have aptly named BiDirectionalMap.
BiDirectionalMap.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "BiDirectionalMap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'@Exposed
'@PredeclaredId
Option Explicit
Private Enum BiDirectionalMapErrors
MismatchedLength = vbObjectError + 1024
SetsNotIterable
KeyDoesNotExist
ValueDoesNotExist
KeyOrValueDoesNotExist = KeyDoesNotExist Or ValueDoesNotExist
End Enum
Private Const MismatchedLengthErrorDesc As String = "Keys and Values must have have the same number of values (i.e. one-to-one correspondence)."
Private Const SetsNotIterableErrorDesc As String = "Key(s), Value(s), or both are is not iterable. For single values, wrap in 'Array()' function."
Private Const DoesNotExistErrorDesc As String = "does not exist. Ensure that the data type is consistent with the original "
Private Type TBiDirectionalMap
KeyCompareMethod As VBA.VbCompareMethod
ValueCompareMethod As VBA.VbCompareMethod
KeysDict As Scripting.Dictionary
ValuesDict As Scripting.Dictionary
End Type
Private this As TBiDirectionalMap
Public Function Create(ByVal keys As Variant, ByVal values As Variant, _
Optional ByVal keyCompareMethod As VBA.VbCompareMethod = vbBinaryCompare, _
Optional ByVal valueCompareMethod As VBA.VbCompareMethod = vbBinaryCompare) As BiDirectionalMap
Errors.GuardNonDefaultInstance Me, BiDirectionalMap, VBA.TypeName(Me)
Dim result As BiDirectionalMap
Set result = New BiDirectionalMap
result.KeyCompareMethod = keyCompareMethod
result.ValueCompareMethod = valueCompareMethod
result.AddRange keys, values
Set Create = result
End Function
Public Property Get KeyCompareMethod() As VBA.VbCompareMethod
KeyCompareMethod = this.KeyCompareMethod
End Property
Friend Property Let KeyCompareMethod(ByVal value As VBA.VbCompareMethod)
Errors.GuardNullReference this.KeysDict, VBA.TypeName(Me) & "." & "KeyCompareMethod"
this.KeyCompareMethod = value
If this.KeysDict.Count = 0 Then
this.KeysDict.CompareMode = this.KeyCompareMethod
End If
End Property
Public Property Get ValueCompareMethod() As VBA.VbCompareMethod
ValueCompareMethod = this.ValueCompareMethod
End Property
Friend Property Let ValueCompareMethod(ByVal value As VBA.VbCompareMethod)
Errors.GuardNullReference this.ValuesDict, VBA.TypeName(Me) & "." & "ValueCompareMethod"
this.ValueCompareMethod = value
If this.ValuesDict.Count = 0 Then
this.ValuesDict.CompareMode = this.ValueCompareMethod
End If
End Property
Public Property Get Count() As Long
If this.KeysDict.Count = this.ValuesDict.Count Then
Count = this.KeysDict.Count
Else
Errors.ThrowError BiDirectionalMapErrors.MismatchedLength, _
VBA.TypeName(Me) & "." & "Count()", _
GetErrorMessage(BiDirectionalMapErrors.MismatchedLength)
End If
End Property
Public Property Get Keys() As Scripting.Dictionary
Set Keys = this.KeysDict
End Property
Public Property Get Values() As Scripting.Dictionary
Set Values = this.ValuesDict
End Property
Public Property Get Key(ByVal valueKey As Variant) As Variant
If this.ValuesDict.Exists(valueKey) Then
AssignProperty(Key) = this.ValuesDict(valueKey)
Else
Errors.ThrowError BiDirectionalMapErrors.KeyDoesNotExist, _
VBA.TypeName(Me) & "." & "Get Key()", _
GetErrorMessage(BiDirectionalMapErrors.KeyDoesNotExist)
End If
End Property
Public Property Let Key(ByVal valueKey As Variant, ByVal value As Variant)
this.KeysDict(valueKey) = value
this.ValuesDict(value) = valueKey
End Property
Public Property Set Key(ByVal valueKey As Variant, ByVal value As Variant)
Set this.KeysDict(valueKey) = value
Set this.ValuesDict(value) = valueKey
End Property
Public Property Get Value(ByVal keyValue As Variant) As Variant
If this.KeysDict.Exists(keyValue) Then
AssignProperty(Value) = keyValue
Else
Errors.ThrowError BiDirectionalMapErrors.ValueDoesNotExist, _
VBA.TypeName(Me) & "." & "Get Value()", _
GetErrorMessage(BiDirectionalMapErrors.ValueDoesNotExist)
End If
End Property
Public Property Let Value(ByVal keyValue As Variant, ByVal key As Variant)
this.ValuesDict(keyValue) = key
this.KeysDict(key) = keyValue
End Property
Public Property Set Value(ByVal keyValue As Variant, ByVal key As Variant)
Set this.ValuesDict(keyValue) = key
Set this.KeysDict(key) = keyValue
End Property
Public Function ContainsKey(ByVal key As Variant) As Boolean
ContainsKey = this.KeysDict.Exists(key)
End Function
Public Function ContainsValue(ByVal value As Variant) As Boolean
ContainsValue = this.ValuesDict.Exists(value)
End Function
Public Function ContainsPair(ByVal key As Variant, ByVal value As Variant) As Boolean
ContainsPair = (ContainsKey(key) And ContainsValue(value))
End Function
Public Sub AddRange(ByVal keys As Variant, ByVal values As Variant)
Errors.GuardNullReference this.KeysDict, VBA.TypeName(Me) & "." & "AddRange()"
Errors.GuardNullReference this.ValuesDict, VBA.TypeName(Me) & "." & "AddRange()"
Dim keysColl As Collection
Set keysColl = IterableToCollection(keys)
Dim valuesColl As Collection
Set valuesColl = IterableToCollection(values)
If keysColl.Count <> valuesColl.Count Then
Errors.ThrowError BiDirectionalMapErrors.MismatchedLength, _
VBA.TypeName(Me) & "." & "AddRange()", _
GetErrorMessage(BiDirectionalMapErrors.MismatchedLength)
End If
Dim i As Long
For i = 1 To keysColl.Count
Add keysColl(i), valuesColl(i)
Next i
End Sub
Public Sub Add(ByVal key As Variant, ByVal value As Variant)
On Error GoTo CleanFail
this.KeysDict.Add key, value
this.ValuesDict.Add value, key
CleanExit:
Exit Sub
CleanFail:
Errors.ThrowError Err.Number, VBA.TypeName(Me) & "." & "Add()", Err.Description
Resume CleanExit
End Sub
Public Sub RemoveRange(ByVal keysOrValues As Variant)
Dim keysOrValueColl As Collection
Set keysOrValueColl = IterableToCollection(keysOrValues)
Dim i As Long
For i = 1 To keysOrValueColl.Count
Remove keysOrValueColl(i)
Next i
End Sub
Public Sub Remove(ByVal keyOrValue As Variant)
If ContainsKey(keyOrValue) Then
Dim val As Variant
val = Value(keyOrValue)
this.KeysDict.Remove keyOrValue
this.ValuesDict.Remove val
ElseIf ContainsValue(keyOrValue) Then
Dim key As Variant
key = Key(keyOrValue)
this.ValuesDict.Remove key
this.KeysDict.Remove keyOrValue
Else
Errors.ThrowError BiDirectionalMapErrors.KeyOrValueDoesNotExist, _
VBA.TypeName(Me) & "." & "Remove()", _
GetErrorMessage(BiDirectionalMapErrors.KeyOrValueDoesNotExist)
End If
End Sub
Public Sub Clear()
If this.KeysDict.Count > 0 Then
this.KeysDict.RemoveAll
End If
If this.ValuesDict.Count > 0 Then
this.ValuesDict.RemoveAll
End If
End Sub
'*****************************************************************************************
'Private Methods / Properties
'*****************************************************************************************
Private Sub Class_Initialize()
Errors.GuardDoubleInitialization this.KeysDict, VBA.TypeName(Me) & "." & "Class_Initialize()"
Set this.KeysDict = New Scripting.Dictionary
Errors.GuardDoubleInitialization this.ValuesDict, VBA.TypeName(Me) & "." & "Class_Initialize()"
Set this.ValuesDict = New Scripting.Dictionary
End Sub
Private Function IterableToCollection(ByVal iterable As Variant) As Collection
Select Case VBA.VarType(iterable)
Case (vbArray + vbVariant) '8204; https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/vartype-function
Set IterableToCollection = ArrayToCollection(iterable)
Case vbObject
Set IterableToCollection = ObjectToCollection(iterable)
End Select
End Function
Private Function ArrayToCollection(ByVal variantArray As Variant) As Collection
ValidateArrayDimensions variantArray, "ArrayToCollection()"
Dim result As Collection
Set result = New Collection
Dim dimensions As Long
dimensions = GetArrayDimensions(variantArray)
Dim i As Long
On Error GoTo CleanFail
Select Case dimensions
Case 1
For i = LBound(variantArray) To UBound(variantArray)
result.Add variantArray(i)
Next i
Case 2
Dim secondDimLBound As Long
secondDimLBound = LBound(variantArray, 1)
For i = LBound(variantArray, 1) To UBound(variantArray, 1)
result.Add variantArray(i, secondDimLBound)
Next i
End Select
Set ArrayToCollection = result
CleanExit:
Exit Function
CleanFail:
ManageIterableError Err.Number, "ArrayToCollection()"
Resume CleanExit
End Function
Private Function ObjectToCollection(ByVal obj As Variant) As Collection
Dim result As Collection
Set result = New Collection
On Error GoTo CleanFail
Dim value As Variant
For Each value In obj
result.Add value
Next
Set ObjectToCollection = result
CleanExit:
Exit Function
CleanFail:
ManageIterableError Err.Number, "ObjectToCollection()"
Resume CleanExit
End Function
Private Property Let AssignProperty(ByRef returnValue As Variant, ByVal value As Variant)
If IsObject(value) Then
Set returnValue = value
Else
returnValue = value
End If
End Property
'*****************************************************************************************
'Error Handling
'*****************************************************************************************
Private Sub ValidateArrayDimensions(ByVal variantArray As Variant, ByVal methodName As String)
Dim dimensions As Long
dimensions = GetArrayDimensions(variantArray)
Select Case dimensions
Case Is > 2
Errors.ThrowError BiDirectionalMapErrors.SetsNotIterable, VBA.TypeName(Me) & "." & methodName
Case Is = 2
Errors.GuardExpression IsMultiColumnArray(variantArray), BiDirectionalMapErrors.SetsNotIterable, VBA.TypeName(Me) & "." & methodName
End Select
End Sub
Private Sub ManageIterableError(ByVal errorNumber As Long, ByVal methodName As String)
Select Case errorNumber
Case Errors.ObjectDoesNotSupportMethodRuntimeError, Errors.TypeMismatchRuntimeError
Errors.ThrowError BiDirectionalMapErrors.SetsNotIterable, _
VBA.TypeName(Me) & "." & methodName, _
GetErrorMessage(BiDirectionalMapErrors.SetsNotIterable)
Case Else
Errors.ThrowError errorNumber, _
VBA.TypeName(Me) & "." & methodName, _
Err.Description
End Select
End Sub
Private Function GetErrorMessage(ByVal errorNumber As BiDirectionalMapErrors) As String
Dim result As String
Select Case errorNumber
Case BiDirectionalMapErrors.MismatchedLength
result = MismatchedLengthErrorDesc
Case BiDirectionalMapErrors.SetsNotIterable
result = SetsNotIterableErrorDesc
Case BiDirectionalMapErrors.KeyDoesNotExist
result = "Key " & DoesNotExistErrorDesc & " keys."
Case BiDirectionalMapErrors.ValueDoesNotExist
result = "Value " & DoesNotExistErrorDesc & " values."
Case BiDirectionalMapErrors.KeyOrValueDoesNotExist
result = "Key or Value " & DoesNotExistErrorDesc & " keys or values."
End Select
GetErrorMessage = result
End Function
Private Function GetArrayDimensions(ByVal variantArray As Variant) As Long
Dim index As Long
On Error Resume Next
Err.Clear
Dim upperBound As Long
Do
index = index + 1
upperBound = UBound(variantArray, index)
Loop Until Err.Number <> 0
On Error GoTo 0
GetArrayDimensions = (index - 1)
End Function
Private Function IsMultiColumnArray(ByVal variantArray As Variant) As Boolean
On Error Resume Next
Err.Clear
Dim value As Variant
value = variantArray(LBound(variantArray), 2)
IsMultiColumnArray = (Err.Number = 0)
On Error GoTo 0
End Function
Essentially, all we are doing is tracking keys and values in 2 separate dictionaries. The underlying KeysDict has key == key and value == value, while the ValuesDict has key == value and value == key. We want to ensure that they are in sync at all times so as to maintain the bijection of the keys/values.
Now we can follow up with a wrapper to work specifically with Enums.
EnumMap.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "EnumMap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'@Exposed
'@PredeclaredId
Option Explicit
Private Mappings As BiDirectionalMap
Public Function Create(ByVal enumns As Variant, ByVal names As Variant, _
Optional ByVal nameCompareMethod As VBA.VbCompareMethod = vbBinaryCompare) As EnumMap
Errors.GuardNonDefaultInstance Me, EnumMap, VBA.TypeName(Me) & "." & "Create()"
Dim result As EnumMap
Set result = New EnumMap
result.SetMappings enumns, names, nameCompareMethod
Set Create = result
End Function
Public Property Get Count() As Long
Errors.GuardNullReference Mappings, VBA.TypeName(Me) & "." & "Count()"
Count = Mappings.Count
End Property
Public Property Get Enumns() As Scripting.Dictionary
Errors.GuardNullReference Mappings, VBA.TypeName(Me) & "." & "Enumns()"
Set Enumns = Mappings.Keys
End Property
Public Property Get Names() As Scripting.Dictionary
Errors.GuardNullReference Mappings, VBA.TypeName(Me) & "." & "Names()"
Set Names = Mappings.Values
End Property
Public Function ToEnum(ByVal name As String) As Long
Errors.GuardNullReference Mappings, VBA.TypeName(Me) & "." & "ToEnum()"
ToEnum = Mappings.Key(name)
End Function
Public Function ToName(ByVal enumValue As Long) As String
Errors.GuardNullReference Mappings, VBA.TypeName(Me) & "." & "ToName()"
ToName = Mappings.Value(enumValue)
End Function
Friend Sub SetMappings(ByVal enumns As Variant, ByVal names As Variant, _
ByVal nameCompareMethod As VBA.VbCompareMethod)
If Mappings Is Nothing Then
Set Mappings = BiDirectionalMap.Create(enumns, names, vbBinaryCompare, nameCompareMethod)
Exit Sub
End If
If Mappings.Count = 0 Then
Set Mappings = BiDirectionalMap.Create(enumns, names, vbBinaryCompare, nameCompareMethod)
End If
End Sub
The we can test like so:
Public Enum TestingEnum
Apples
Oranges
Cars
Lemons
Trees
Giraffes
End Enum
Private Sub Tester()
Dim enumValues() As Variant
enumValues() = Array(Apples, Oranges, Cars, Lemons, Trees, Giraffes)
Dim enumNames() As Variant
enumNames() = Array("Apples", "Oranges", "Cars", "Lemons", "Trees", "Giraffes")
Dim map As EnumMap
Set map = EnumMap.Create(enumValues, enumNames)
Debug.Print map.ToEnum("Cars")
Debug.Print map.ToName(Cars)
Debug.Print map.Count()
Debug.Assert map.names.Exists("Trucks")
Debug.Assert map.enumns.Exists(10)
End Sub
The only caveat with a generic wrapper is that does not support intellisense, but the reusability/portability that it affords outways this in my mind.
For reference, below is the Errors module referenced in the 2 classes above.
Errors.bas
Attribute VB_Name = "Errors"
Option Explicit
Public Const InvalidProcedureCallOrArgumentError As Long = 5
Public Const TypeMismatchRuntimeError As Long = 13
Public Const ObjectDoesNotSupportMethodRuntimeError As Long = 438
Public Const ObjectAlreadyInitializedError As Long = 1004 'Technically this is an Application-defined or object-defined error
Public Const InvalidProcedureCallOrArgumentErrorDesc As String = "Invalid procedure call or argument."
Public Const ObjectAlreadyInitializedErrorDesc As String = "Object is already initialized."
Public Const NonDefaultInstanceErrorDesc As String = "Method should be invoked from the default/predeclared instance of this class."
Public Const NullObjectErrorDesc As String = "Object reference cannot be Nothing."
Public Sub GuardNonDefaultInstance(ByVal instance As Object, ByVal defaultInstance As Object, _
Optional ByVal source As String = "Errors", _
Optional ByVal message As String = NonDefaultInstanceErrorDesc)
GuardExpression Not instance Is defaultInstance, errorNumber:=InvalidProcedureCallOrArgumentError, source:=source, message:=message
End Sub
Public Sub GuardDoubleInitialization(ByVal instance As Object, _
Optional ByVal source As String = "Errors", _
Optional ByVal message As String = ObjectAlreadyInitializedErrorDesc)
GuardExpression Not instance Is Nothing, errorNumber:=ObjectAlreadyInitializedError, source:=source, message:=message
End Sub
Public Sub GuardNullReference(ByVal instance As Object, _
Optional ByVal source As String = "Errors", _
Optional ByVal message As String = NullObjectErrorDesc)
GuardExpression instance Is Nothing, errorNumber:=InvalidProcedureCallOrArgumentError, source:=source, message:=message
End Sub
Public Sub GuardExpression(ByVal throw As Boolean, _
Optional ByVal errorNumber As Long = InvalidProcedureCallOrArgumentError, _
Optional ByVal source As String = "Errors", _
Optional ByVal message As String = InvalidProcedureCallOrArgumentErrorDesc)
If throw Then
ThrowError IIf(errorNumber = 0, InvalidProcedureCallOrArgumentError, errorNumber), source, message
End If
End Sub
Public Sub ThrowError(ByVal errorNumber As Long, Optional ByVal source As String = "Errors", _
Optional ByVal message As String = "Invalid procedure call or argument.")
VBA.Information.Err.Err.Raise errorNumber, source:=source, message:=message
End Sub
AsPropertyis not defined anywhere - is it supposed to be a public member of each enum, for example a member ofEnum Testing?AsCountis not defined or implemented in the select case statement. \$\endgroup\$