Is there a way to get the enums in VBA?

Question

Is there a way to get the enums in VBA? Something like this example for C#, but for VBA?

using System;

class EnumsExampleZ
{
    private enum SiteNames
             


        

Answer 1

I think that the marvel CPearson's site has the answer with the [_First] and [_Last] trick. I have the need of speed up a lot of DB reading just to populate combo and list boxes with values in Office VBA application, and I just translate them to Enums. And of course, do a For Each like, with the For Next is a must, and the [_First] and [_Last] is the way to go. But, I have a lot of non-sequential Enums, each with 10 to 40 Enum itens, and code for each is too tediously. To unify all my combo and listbox feeding needs, I adapted CPearson's trick to non-sequential Enums too:

Sub EnumValueNamesWrapingAndUnwrapingToClipboard()
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' This creates a text string of the comma separated value names of an
        ' Enum data type. Put the cursor anywhere within an Enum definition
        ' and the code will create a comma separated string of all the
        ' enum value names. This can be used in a Select Case for validating
        ' values passed to a function. If the cursor is not within an enum
        ' definition when the code is executed, the results are unpredicable by CPearson
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Dim N As Long
        Dim txt As String, S As String
        Dim SL As Long, EL As Long, SC As Long, EC As Long
        Dim DataObj As MSForms.DataObject
        Dim auxTitle As String, auxStrValue As String, strAuxCase As String
        Dim counter As Integer, EnumMin As Integer, EnumMax As Integer
        Dim auxValue As Variant
        Dim EnumIsSequential As Boolean

        Const STR_ENUM As String = "enum "
            If VBE.ActiveCodePane Is Nothing Then
                Exit Sub
            End If
            With VBE.ActiveCodePane
                .GetSelection SL, SC, EL, EC
                With .CodeModule
                    S = .Lines(SL, 1)
                    Do Until InStr(1, S, STR_ENUM, vbTextCompare) > 0
                        N = N + 1
                        S = .Lines(SL - N, 1)
                    Loop
                    'Function title
                    auxTitle = Right$(S, Len(S) - InStr(1, S, STR_ENUM, vbTextCompare) - Len(STR_ENUM) + Len(" "))
                    N = SL - N + 1
                    S = .Lines(N, 1)
                    Do
                        S = .Lines(N, 1)
                        If InStr(1, S, "end enum", vbTextCompare) = 0 And InStr(1, S, "'", vbTextCompare) = 0 Then
                            txt = txt & " " & Trim(S) & ","
                        End If
                        N = N + 1
                    Loop Until InStr(1, S, "end enum", vbTextCompare) > 0
                    ReDim auxValue(0)
                    ReDim Preserve auxValue(0 To StringCountOccurrences(txt, "=") - 2) 'because of [_First] and [_Last]
                    For counter = 1 To UBound(auxValue)
                        auxStrValue = RetornaElementoDesignado(counter + 1, Left(txt, Len(txt) - 1))
                        If counter = 1 Then
                            EnumMin = CInt(Trim$(Right$(auxStrValue, Len(auxStrValue) - InStrRev(auxStrValue, "="))))
                            auxValue(counter) = Trim$(Left$(auxStrValue, InStr(1, auxStrValue, " = ")))
                        ElseIf counter = UBound(auxValue) Then
                            EnumMax = CInt(Trim$(Right$(auxStrValue, Len(auxStrValue) - InStrRev(auxStrValue, "="))))
                            auxValue(counter) = Trim$(Left$(auxStrValue, InStr(1, auxStrValue, " = ")))
                        Else
                            auxValue(counter) = Trim$(Left$(auxStrValue, InStr(1, auxStrValue, " = ")))
                        End If
                    Next counter
                End With
            End With
            EnumIsSequential = NumElements(auxValue) - 1 = EnumMax - EnumMin + 1
            strAuxCase = "Function ReturnNameEnum" & auxTitle & " (ByVal WhichEnum As " & auxTitle & ")As String" & vbCrLf _
                                 & "  Select Case WhichEnum" & vbCrLf
            For counter = 1 To UBound(auxValue)
                strAuxCase = strAuxCase & "     Case Is = " & auxTitle & "." & auxValue(counter) & vbCrLf _
                    & "          ReturnNameEnum" & auxTitle & " = " & ParseSpecialCharsAndDataTypeForSQL(auxValue(counter), False, True, False) & vbCrLf
            Next counter
            If EnumIsSequential Then
                strAuxCase = strAuxCase & "     Case Else" & vbCrLf _
                    & "          debug.print " & """Passed invalid """ & " & WhichEnum & " & """ WhichEnum As " & auxTitle & "! """ & vbCrLf _
                    & "    End Select" & vbCrLf _
                    & "End Function" & vbCrLf _
                    & "Function LoadEnum" & auxTitle & "InArray () As Variant" & vbCrLf _
                    & "    'If Enum is Sequential" & vbCrLf _
                    & "    Dim items() As Variant, item As Long, counter As Long" & vbCrLf _
                    & "    For item = " & auxTitle & ".[_first] To " & auxTitle & ".[_last]" & vbCrLf _
                    & "        counter = counter + 1" & vbCrLf _
                    & "    Next" & vbCrLf _
                    & "    ReDim items(counter * 2 - 1) '-1: it's 0-based..." & vbCrLf _
                    & "    For item = " & auxTitle & ".[_first] To " & auxTitle & ".[_last]" & vbCrLf _
                    & "        items(item * 2) = item" & vbCrLf _
                    & "    items(item * 2 + 1) = ReturnNameEnum" & auxTitle & "(item)" & vbCrLf _
                    & "        items(item * 2) = item" & vbCrLf _
                    & "    Next" & vbCrLf _
                    & "    LoadEnum" & auxTitle & "InArray=items()" & vbCrLf _
                    & "End Function"
            Else
                strAuxCase = strAuxCase & "     Case Else" & vbCrLf _
                  & "          debug.print " & """Passed invalid """ & " & WhichEnum & " & """ WhichEnum As " & auxTitle & "! """ & vbCrLf _
                  & "    End Select" & vbCrLf _
                  & "End Function" & vbCrLf _
                  & "Function LoadEnum" & auxTitle & "InArray () As Variant" & vbCrLf _
                  & "    'For Non-Sequential Enum" & vbCrLf _
                  & "    Dim items() As Variant, item As Long, ExistingEnum As Long" & vbCrLf _
                  & "    For item = " & auxTitle & ".[_first] To " & auxTitle & ".[_last]" & vbCrLf _
                  & "        if ReturnNameEnum" & auxTitle & "(item) <> """" then" & vbCrLf _
                  & "            ExistingEnum = ExistingEnum + 1" & vbCrLf _
                  & "            auxExistingEnum = auxExistingEnum & CStr(item) & "",""" & vbCrLf _
                  & "        end if" & vbCrLf _
                  & "    Next" & vbCrLf _
                  & "    auxExistingEnum = Left$(auxExistingEnum, Len(auxExistingEnum) - 1)" & vbCrLf _
                  & "    arrayExistingEnum = Split(auxExistingEnum, "","")" & vbCrLf _
                  & "    ReDim items(ExistingEnum * 2 - 1) '-1: it's 0-based..." & vbCrLf _
                  & "    If ReturnNameEnum" & auxTitle & "(arrayExistingEnum(item)) = """" Then GoTo continue" & vbCrLf _
                  & "        items(item * 2) = arrayExistingEnum(item)" & vbCrLf _
                  & "        items(item * 2 + 1) = ReturnNameEnum" & auxTitle & "(arrayExistingEnum(item))" & vbCrLf _
                  & "continue:" & vbCrLf _
                  & "    Next" & vbCrLf _
                  & "    LoadEnum" & auxTitle & "InArray=items()" & vbCrLf _
                  & "End Function"
            End If
            Set DataObj = New MSForms.DataObject
            With DataObj
                .SetText strAuxCase
                .PutInClipboard
                Debug.Print strAuxCase
            End With
            Set DataObj = Nothing
        End Sub

I added skip comment lines - I do a lot while developing.

I did not treat Enum that is not in Ascendant order; could be done, but I'm too OCD to allow an unordered Enum ;) and ordinarily, my Enums are coming from DB with an ORDER BY on the proper value (see at end of this answer).

Of course, it depends on [_First] and [_Last] values added properly.

And, answering your question, you can do a:

?ReturnNameEnumWhateverNamedItIs(FruitType.Apple)
Apple

As a bonus, and for me the main reason to adapt the CPearson's procedure, it loads in a unidimensional array tuples of value/name of Enum; so, we can navigate all Enum values with:

auxArray=LoadEnumWhateverNameYouGaveItInArray()
For counter = lbound(auxArray) to ubound(auxArray) step 2
     EnumValue = auxArray(counter)
     EnumStringName = auxArray(counter+1)
Next counter

The procedure is generating one of two different functions LoadEnumWhateverNameYouGaveItInArray() versions based if Enum is sequential or not.

You can forget about the sequential; the non-sequential enum function grab both situations; I left here because I first developed it and after adapted to the non-sequential case, and we never know when we'll need less code lines ;)

Notice that although Enum is natively Long, I used Integer in counter/EnumMin/EnumMax, just because the Enums that we need to know its names are less than hundred, like fruit names.

Hope it helps someone.

Edit: To complete the explanation, this is the procedure that I use to extract Enum from tables and write them in a static module:

Sub CreateEnumBasedOnTableValues(ByVal EnumName As String, ByVal CnnStr As String _
   , ByVal DataS As String, ByVal strSQL As String _
   , ByVal EnumValueField As String, ByVal EnumNameField As String _
   , ByVal TreatIllegalNames As Boolean, ByVal EliminateWhiteSpaces As Boolean _
   , Optional ByVal ToEscapeWhiteSpace As String = "")
            Dim DataObj As MSForms.DataObject
            Dim cnn As ADODB.Connection
            Dim rst As ADODB.Recordset
            Dim auxEnum As String, bBracket As String, eBracket As String, auxRegex As String
            Dim LastValue As Long

            Set cnn = New ADODB.Connection
            Set rst = New ADODB.Recordset
            cnn.Open CnnStr & vbCrLf & DataS
            rst.Open strSQL, cnn, adOpenForwardOnly, adLockReadOnly, adCmdText
            If TreatIllegalNames Then bBracket = "[": eBracket = "]"
            auxEnum = "Public Enum " & EnumName & vbCrLf
            auxEnum = auxEnum & "    [_First] = "
            With rst
                .MoveFirst
                auxEnum = auxEnum & CStr(.Fields(EnumValueField)) & vbCrLf
                Do While Not .EOF
                    auxEnum = auxEnum & "    " & bBracket _
                            & IIf(EliminateWhiteSpaces, Replace(.Fields(EnumNameField), " ", ToEscapeWhiteSpace), .Fields(EnumNameField)) _
                            & eBracket & " = " & CStr(.Fields(EnumValueField)) & vbCrLf
                    LastValue = .Fields(EnumValueField)
                    .MoveNext
                Loop
                .Close
            End With
            auxEnum = auxEnum & "    [_Last] = " & CStr(LastValue) & vbCrLf
            auxEnum = auxEnum & "End Enum " & vbCrLf

            Set rst = Nothing
            cnn.Close
            Set cnn = Nothing
            Set DataObj = New MSForms.DataObject
            With DataObj
                .SetText auxEnum
                .PutInClipboard
                Debug.Print auxEnum
            End With
            Set DataObj = Nothing
     End Sub

Just remember to pass the strSQL like that:

"SELECT EnumNameField, EnumValueField " & _
"FROM tblTarget WHERE EnumValueField Is NOT NULL " & _
"ORDER BY EnumValueField"

Usually, I use the EliminateWhiteSpaces boolean with ToEscapeWhiteSpace = "_", but is a personal preference.

Answer 2

Any method which does not return a keyed collection or (preferably a scripting dictionary) will be prone to errors if the enumeration range is not a contiguous range, such as the case where you are using the enumeration to map to bits. My solution to this has been to develop a class of 'EnumerationDictionary' which allows arrays of the enumeration or the enumeration names to be returned, and name to be looked up given an enumeration and a string to be used to retrieve an enumeration. The example below is for colours in a word document and shows how to combine an internal enumeration with additional user defined values. Its a bit clunky but works very well.

Option Explicit

' A new enumeration for colour has been created to allow
' the inclusion of custom colours
' The wdColor enumeration values are the RGB vlaue as a decimal signed long
' For the hexadecimal representation the colours are BGR not RGB
' e.g. 0xXXBBGGRR not Ox00RRGGBB

Public Enum UserColour
    Aqua = wdColorAqua                                                     '13421619    0x00CCCC33
    Automatic = wdColorAutomatic                                           '-16777216   0xFF000000
    Black = wdColorBlack                                                   '0           0x00000000
    Blue = wdColorBlue                                                     '16711680    0x00FF0000
    BlueGray = wdColorBlueGray                                             '10053222
    BrightGreen = wdColorBrightGreen                                       '65280       0x0000FF00
    Brown = wdColorBrown                                                   '13209
    DarkBlue = wdColorDarkBlue                                             '8388608
    DarkGreen = wdColorDarkGreen                                           '13056
    DarkRed = wdColorDarkRed                                               '128         0x00000080
    DarkTeal = wdColorDarkTeal                                             '6697728
    DarkYellow = wdColorDarkYellow                                         '32896
    Gold = wdColorGold                                                     '52479
    Gray05 = wdColorGray05                                                 '15987699
    Gray10 = wdColorGray10                                                 '15132390
    Gray125 = wdColorGray125                                               '14737632
    Gray15 = wdColorGray15                                                 '14277081
    Gray20 = wdColorGray20                                                 '13421772
    Gray25 = wdColorGray25                                                 '12632256
    Gray30 = wdColorGray30                                                 '11776947
    Gray35 = wdColorGray35                                                 '10921638
    Gray375 = wdColorGray375                                               '10526880
    Gray40 = wdColorGray40                                                 '10066329
    Gray45 = wdColorGray45                                                 '9211020
    Gray50 = wdColorGray50                                                 '8421504
    Gray55 = wdColorGray55                                                 '7566195
    Gray60 = wdColorGray60                                                 '6710886
    Gray625 = wdColorGray625                                               '6316128
    Gray65 = wdColorGray65                                                 '5855577
    Gray70 = wdColorGray70                                                 '5000268
    Gray75 = wdColorGray75                                                 '4210752
    Gray80 = wdColorGray80                                                 '3355443
    Gray85 = wdColorGray85                                                 '2500134
    Gray875 = wdColorGray875                                               '2105376
    Gray90 = wdColorGray90                                                 '1644825
    Gray95 = wdColorGray95                                                 '789516
    Green = wdColorGreen                                                   '32768
    Indigo = wdColorIndigo                                                 '10040115
    Lavender = wdColorLavender                                             '16751052
    LightBlue = wdColorLightBlue                                           '16737843
    LightGreen = wdColorLightGreen                                         '13434828
    LightOrange = wdColorLightOrange                                       '39423
    LightTurquoise = wdColorLightTurquoise                                 '16777164
    LightYellow = wdColorLightYellow                                       '10092543
    Lime = wdColorLime                                                     '52377
    OliveGreen = wdColorOliveGreen                                         '13107
    Orange = wdColorOrange                                                 '26367
    PaleBlue = wdColorPaleBlue                                             '16764057
    Pink = wdColorPink                                                     '16711935
    Plum = wdColorPlum                                                     '6697881
    Red = wdColorRed                                                       '255         0x000000FF
    Rose = wdColorRose                                                     '13408767
    SeaGree = wdColorSeaGreen                                              '6723891
    SkyBlue = wdColorSkyBlue                                               '16763904
    Tan = wdColorTan                                                       '10079487
    Teal = wdColorTeal                                                     '8421376
    Turquoise = wdColorTurquoise                                           '16776960
    Violet = wdColorViolet                                                 '8388736
    White = wdColorWhite                                                   '16777215    0x00FFFFFF
    Yellow = wdColorYellow                                                 '65535
    ' Add custom s from this point onwards
    HeadingBlue = &H993300                                                 'RGB(0,51,153)   0x00993300
    HeadingGreen = &H92D050                                                'RGB(146,208,80) 0x0050D092

End Enum


Private Type Properties

    enum_gets_string                           As Scripting.Dictionary
    string_gets_enum                           As Scripting.Dictionary

End Type

Private p                                       As Properties

Private Sub Class_Initialize()

    Set p.enum_gets_string = New Scripting.Dictionary
    Set p.string_gets_enum = New Scripting.Dictionary

    With p.enum_gets_string

        .Add Key:=Aqua, Item:="Aqua"
        .Add Key:=Automatic, Item:="Automatic"
        .Add Key:=Black, Item:="Black"
        .Add Key:=Blue, Item:="Blue"
        .Add Key:=BlueGray, Item:="BlueGray"
        .Add Key:=BrightGreen, Item:="BrightGreen"
        .Add Key:=Brown, Item:="Brown"
        .Add Key:=DarkBlue, Item:="DarkBlue"
        .Add Key:=DarkGreen, Item:="DarkGreen"
        .Add Key:=DarkRed, Item:="DarkRed"
        .Add Key:=DarkTeal, Item:="DarkTeal"
        .Add Key:=DarkYellow, Item:="DarkYellow"
        .Add Key:=Gold, Item:="Gold"
        .Add Key:=Gray05, Item:="Gray05"
        .Add Key:=Gray10, Item:="Gray10"
        .Add Key:=Gray125, Item:="Gray125"
        .Add Key:=Gray15, Item:="Gray15"
        .Add Key:=Gray20, Item:="Gray20"
        .Add Key:=Gray25, Item:="Gray25"
        .Add Key:=Gray30, Item:="Gray30"
        .Add Key:=Gray35, Item:="Gray35"
        .Add Key:=Gray375, Item:="Gray375"
        .Add Key:=Gray40, Item:="Gray40"
        .Add Key:=Gray45, Item:="Gray45"
        .Add Key:=Gray50, Item:="Gray50"
        .Add Key:=Gray55, Item:="Gray55"
        .Add Key:=Gray60, Item:="Gray60"
        .Add Key:=Gray625, Item:="Gray625"
        .Add Key:=Gray65, Item:="Gray65"
        .Add Key:=Gray70, Item:="Gray70"
        .Add Key:=Gray75, Item:="Gray75"
        .Add Key:=Gray80, Item:="Gray80"
        .Add Key:=Gray85, Item:="Gray85"
        .Add Key:=Gray875, Item:="Gray875"
        .Add Key:=Gray90, Item:="Gray90"
        .Add Key:=Gray95, Item:="Gray95"
        .Add Key:=Green, Item:="Green"
        .Add Key:=Indigo, Item:="Indigo"
        .Add Key:=Lavender, Item:="Lavender"
        .Add Key:=LightBlue, Item:="LightBlue"
        .Add Key:=LightGreen, Item:="LightGreen"
        .Add Key:=LightOrange, Item:="LightOrange"
        .Add Key:=LightTurquoise, Item:="LightTurquoise"
        .Add Key:=LightYellow, Item:="LightYellow"
        .Add Key:=Lime, Item:="Lime"
        .Add Key:=OliveGreen, Item:="OliveGreen"
        .Add Key:=Orange, Item:="Orange"
        .Add Key:=PaleBlue, Item:="PaleBlue"
        .Add Key:=Pink, Item:="Pink"
        .Add Key:=Plum, Item:="Plum"
        .Add Key:=Red, Item:="Red"
        .Add Key:=Rose, Item:="Rose"
        .Add Key:=SeaGree, Item:="SeaGreen"
        .Add Key:=SkyBlue, Item:="SkyBlue"
        .Add Key:=Tan, Item:="Tan"
        .Add Key:=Teal, Item:="Teal"
        .Add Key:=Turquoise, Item:="Turquoise"
        .Add Key:=Violet, Item:="Violet"
        .Add Key:=White, Item:="White"
        .Add Key:=Yellow, Item:="Yellow"
        .Add Key:=HeadingBlue, Item:="HeadingBlue"
        .Add Key:=HeadingGreen, Item:="HeadingGreen"

    End With

    ' Now compile the reverse lookup
    Set p.string_gets_enum = ReverseDictionary(p.enum_gets_string, "Reversing userCOLOUR.enum_gets_string")

End Sub

Public Property Get Items() As Variant
    proj.Log.Trace s.locale, "{0}.Items", TypeName(Me)

    Set Items = p.enum_gets_string.Items

End Property


Public Property Get Enums() As Variant
' Returns an array of Enums")

    Set Enums = p.enum_gets_string.Keys

End Property


Public Property Get Item(ByVal this_enum As UserColour) As String
' Returns the Item for a given Enum")

    Item = p.enum_gets_string.Item(this_enum)

End Property


' VBA will not allow a property/function Item of 'Enum' so we use
' ü (alt+0252) to sidestep the keyword clash for this property Item
Public Property Get Enüm(ByVal this_item As String) As UserColour

    Enüm = p.string_gets_enum.Item(this_item)

End Property


Public Function HoldsEnum(ByVal this_enum As UserColour) As Boolean

    HoldsEnum = p.enum_gets_string.Exists(this_enum)

End Function


Public Function LacksEnum(ByVal this_enum As UserColour) As Boolean

    LacksEnum = Not Me.HoldsEnum(this_enum)

End Function


Public Function HoldsItem(ByVal this_item As String) As Boolean

    HoldsItem = p.string_gets_enum.Exists(this_item)

End Function


Public Function LacksItem(ByVal this_item As String) As Boolean

    LacksItem = Not Me.HoldsItem(this_item)

End Function


Public Function Count() As Long

    Count = p.enum_gets_string.Count

End Function

Plus the following utility to reverse dictionaries.

Public Function ReverseDictionary(ByRef this_dict As Scripting.Dictionary) As Scripting.Dictionary
' Swaps keys for items in scripting.dictionaries.
' Keys and items must be unique which is usually the case for an enumeration

    Dim my_key                                  As Variant
    Dim my_keys                                 As Variant
    Dim my_reversed_map                         As Scripting.Dictionary
    Dim my_message                              As String

    On Error GoTo key_is_not_unique
    Set my_reversed_map = New Scripting.Dictionary
    my_keys = this_dict.Keys

    For Each my_key In my_keys

        my_reversed_map.Add Key:=this_dict.Item(my_key), Item:=my_key

    Next

    Set ReverseDictionary = my_reversed_map
    Exit Function

key_is_not_unique:

    On Error GoTo 0

    MsgBox _
        Title:="Reverse Dictionary Error", _
        Prompt:="The key and item are not unique Key:=" & my_key & " Item:= " & this_dict.Item(my_key), _
        Buttons:=vbOKOnly

    Set ReverseDictionary = Nothing

End Function