Share via


[VBA] Preferred number AKA Enumeration values 1,2,4,8,16, .....

Sometimes you need to know which flags are set in an object, eg. a tablefield. There are a lot of consts and enums. ..

Because of being very lazy and slowly in brain I descided to write a function for this and put it in a little class.

'---------------------------------------------------------------------------------------
' Module    : cBitSetInfo
' Type      : Class

' Author    : Jedeck, Sven
' eMail     : sven@jedeck.de
' Date      : 15.12.2014
' Version   : 0.1
 
' Purpose   : Seeking comfortable for set Bits/Consts/EnumValues
 
' Hints     : As you are in general not able to look explicit to EMPTY/0/null (dont speaking about NULL) _
              the class returns >> BitSetType_en.BST_0_Empty = 0 << when null/0 ist delivered. _
              By combing a null value with others you wont get right result !! _
              But in praxis combing with potential null/0 wont be a serious scenario _
 
' Licence   : Free use for every case, but don't miss hint to author and _
              do NOT claim for any rights to this.
 
' Methods   : _
     . _
          1) GetBitSetType (SearchedBit_prm As  Long, BitField_prm As Long) As  BitSetType_en _
               Returns set/state of Bit search result _
               This is the main function of class _
               . _
          2) GetBitSetName (SearchedBit_prm As  Long, BitField_prm As Long) As  String _
               Returns the Enum  Value Name of the set from Bit search result _
              . _
          3) GetBitSetDesc (SearchedBit_prm As  Long, BitField_prm As Long) As  String _
               Returns the Enum  Value Name of the set from Bit search result _
              . _
          4) IsIn (SearchedBit_prm As  Long, BitField_prm As Long) As  Boolean _
               Return Boolean  if delivered Values are in Seek BitField _
               Thats the "fast" and propably most used function
 
' Properties: No
 
' Private Procedures: _
    . _
        1) Class  Init // Calls Init_PseudoConsts _
        2) Init_PseudoConsts // _
           Set values to string vars for getting information about the Enum: BitSetType_en _
        3) RE_BitSetType _
           Returns name and description of the EnumValues.
 
' Use Example:
 
' In Modul:
 
' ########
' Example Beginn
' ########
 
'Option Compare Database
'Option Explicit
'
'
'Enum tmp_en
'  V1 = 1
'  V2 = 2
'  V3 = 4
'  V4 = 8
'  V5 = 16
'  V6 = 32
'  V7 = 64
'  V8 = 128
'End Enum
 
'Public Sub main()
'
'  Dim Search_lcl As tmp_en
'  Dim Field_lcl As tmp_en
'
'  Dim MyBitSet As New cBitSetInfo
'
'  Search_lcl = V1 + V2 + V5
'  Field_lcl = V1 + V2 + V3
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Search_lcl = V1 + V2 + V5
'  Field_lcl = V1 + V2
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Search_lcl = V1 + V2 + V5
'  Field_lcl = V1 + V2 + V7
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Search_lcl = V1 + V2 + V5
'  Field_lcl = V0
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Search_lcl = V1 + V2 + V5
'  Field_lcl = V0 + V1
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Search_lcl = V0 + V1 + V2 + V5
'  Field_lcl = V1
'
'  Debug.Print "----------"
'  Debug.Print MyBitSet.IsIn(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetType(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetDesc(Search_lcl, Field_lcl)
'  Debug.Print MyBitSet.GetBitSetName(Search_lcl, Field_lcl)
'
'  Set MyBitSet = Nothing
'
'End Sub
 
' ########
' Example End
' ########
 
 
 
'
'---------------------------------------------------------------------------------------
 
Option Compare Database
Option Explicit
 
 
Public Enum  BitSetType_en
  BST____0_Error = -4
  BST___0_MoreIn = -2
  BST__0_EmptyBitField = -1
  BST_0_Empty = 0
  BST_1_NoOneIn = 1
  BST_3_AllIn = 2
  BST_4_Identic = 4
End Enum
    Private _
         Pcst_BST____0_Error_Desc As  String, _
         Pcst_BST___0_MoreIn_Desc As  String, _
   Pcst_BST__0_EmptyBitField_Desc As  String, _
            Pcst_BST_0_Empty_Desc As  String, _
          Pcst_BST_1_NoOneIn_Desc As  String, _
            Pcst_BST_3_AllIn_Desc As  String, _
          Pcst_BST_4_Identic_Desc As  String
    Private _
         Pcst_BST____0_Error_Name As  String, _
         Pcst_BST___0_MoreIn_Name As  String, _
   Pcst_BST__0_EmptyBitField_Name As  String, _
            Pcst_BST_0_Empty_Name As  String, _
          Pcst_BST_1_NoOneIn_Name As  String, _
            Pcst_BST_3_AllIn_Name As  String, _
          Pcst_BST_4_Identic_Name As  String
 
Private Enum  RE_Type_en
  Name_ReType
  Desc_ReType
End Enum
 
' ########
Const EndOfDecl As String  = "EndOfDecl"
' ########
'
'
 
Public Function  GetBitSetType( _
                                SearchedBit_prm As  Long, _
                                   BitField_prm As  Long _
                             ) As  BitSetType_en
' --------------------
'  Procedure : GetBitSetType
'  Purpose   : _
               Returns set/state of Bit search result _
               This is the main function of class _
 
' ----------
  Dim _
       eReturn_lcl As  BitSetType_en, _
           Left_In As  Integer, _
          Right_In As  Integer, _
           Both_In As  Integer, _
                 i As  Integer, _
         SearchBit As  Integer, _
          FieldBit As  Integer
' ----------
 
On Error  GoTo GetBitSetType_Error
' ----------
 
  For i = 1 To 31
   
  ' ----------
      If BitField_prm = 0 _
                  Then _
                            eReturn_lcl = BST__0_EmptyBitField: _
                            Exit For
                                   
      If SearchedBit_prm = 0 _
                  Then _
                            eReturn_lcl = BST_0_Empty: _
                            Exit For
     
      SearchBit = _
                  (SearchedBit_prm& And  2 ^ (i - 1)) _
                               / _
                  2 ^ (i - 1)
                   
      FieldBit = _
                  (BitField_prm& And  2 ^ (i - 1)) _
                              / _
                  2 ^ (i - 1)
       
      ' ----------
      Select Case  SearchBit _
                      + _
                  FieldBit
                                          Case 0
          Case 1
                  ' ----------
                  Select Case  (SearchedBit_prm And  2 ^ (i - 1)) _
                                          / _
                              2 ^ (i - 1)
                       
                          Case 0
                                  Right_In = _
                                              Right_In + 1
                          Case 1
                                  Left_In = _
                                              Left_In + 1
                  End Select
                  ' ----------
          Case 2
                  Both_In = _
                             Both_In + 1
      End Select
      ' ----------
       
  Next i
 
  '-------------
 
  If Left_In > 0 Then
  eReturn_lcl = BST___0_MoreIn
  
  ElseIf Both_In = 0 Then
  eReturn_lcl = BST_1_NoOneIn
   
  ElseIf Both_In > 0 And Right_In > 0 And Left_In = 0 Then
  eReturn_lcl = BST_3_AllIn
   
  ElseIf Both_In > 0 And Right_In = 0 And Left_In = 0 Then
  eReturn_lcl = BST_4_Identic
   
  End If
 
 
' ----------
GetBitSetType_Error:
 
  Select Case  Err
      
     Case 0
        GetBitSetType = _
                  eReturn_lcl
 
     Case Else     'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetBitSetType of Klassenmodul cBitSetInfo"
        GetBitSetType = _
                  BST____0_Error
 
  End Select
 
End Function
' GetBitSetType
'
 
Public Function  GetBitSetName( _
                               SearchedBit_prm As Long,
                               BitField_prm As Long _
                            ) As String
 
'---------------------------------
'  Procedure : GetBitSetName
'  Purpose   : Returns the Enum Value NAME of the set from Bit search result
 
'----------
 
Dim _
     sReturn_lcl As  String
 
'----------
On Error  GoTo GetBitSetName_Error
'----------
 
  sReturn_lcl = RE_BitSetType(GetBitSetType(SearchedBit_prm, BitField_prm), Name_ReType)
 
'----------
GetBitSetName_Error:
 
  Select Case  Err
      
     Case 0
          
         GetBitSetName = sReturn_lcl
          
     Case Else       'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetBitSetName of Klassenmodul cBitSetInfo"
           
          GetBitSetName = ""
 
  End Select
 
End Function
' GetBitSetName
'
 
Public Function  GetBitSetDesc( _
                               SearchedBit_prm As Long, _
                               BitField_prm As Long _
                            ) As String
 
'---------------------------------
'  Procedure : GetBitSetDesc
'  Purpose   : Returns the Enum Value DESCRIPTION of the set from Bit search result
 
'----------
 
Dim _
     sReturn_lcl As  String
       
'----------
On Error  GoTo GetBitSetDesc_Error
'----------
 
  sReturn_lcl = RE_BitSetType(GetBitSetType(SearchedBit_prm, BitField_prm), Desc_ReType)
 
'----------
GetBitSetDesc_Error:
 
  Select Case  Err
      
     Case 0
        GetBitSetDesc = sReturn_lcl
     Case Else       'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetBitSetDesc of Klassenmodul cBitSetInfo"
        GetBitSetDesc = "Error"
 
  End Select
 
End Function
' GetBitSetDesc
'
 
Public Function  IsIn( _
             SearchedBit_prm As  Long, _
             BitField_prm As  Long _
           ) As  Boolean
                     
'---------------------------------------------------------------------------------------
'  Procedure : IsIn
'  Purpose   : _
               Return Boolean  if delivered Values are in Seek BitField _
               Thats the "fast" and propably most used function
 
'----------
 
Dim _
     bReturn_lcl As  Boolean, _
   GetBitSet_lcl As  BitSetType_en
 
'---------
On Error  GoTo IsIn_Error
'---------
 
    GetBitSet_lcl = _
                     GetBitSetType( _
                                     SearchedBit_prm, _
                                     BitField_prm _
                                  )
       
    If GetBitSet_lcl > BST_1_NoOneIn _
                      Then _
                                      bReturn_lcl = True  _
                              Else _
                                      bReturn_lcl = False
                                       
       
'---------
IsIn_Error:
 
  Select Case  Err
      
     Case 0
          IsIn = bReturn_lcl
 
     Case Else     'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IsIn of Klassenmodul cBitSetInfo"
          IsIn = False
  End Select
 
End Function
' IsIn
'
 
Private Sub  Class_Initialize()
 
'---------------------------------
'  Procedure : Class_Initialize
'  Purpose   : Calls Init_PseudoConsts
 
'----------
 
On Error  GoTo Class_Initialize_Error
'----------
 
  Call Init_PseudoConsts
 
'----------
Class_Initialize_Error:
 
  Select Case  Err
      
     Case 0
      
     Case Else       'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Class_Initialize of Klassenmodul cBitSetInfo"
 
  End Select
 
End Sub
'
'
 
Private Sub  Init_PseudoConsts()
 
'---------------------------------
'  Procedure : Init_PseudoConsts
'  Purpose   : Set values for the "Pseudo"-Consts
 
 
'----------
On Error  GoTo Init_PseudoConsts_Error
'----------
 
       Pcst_BST____0_Error_Desc = "Error"
       Pcst_BST___0_MoreIn_Desc = "More Values seeked then in SeekField"
    Pcst_BST__0_EmptyBitField_Desc = "No Values in SeekField"
         Pcst_BST_0_Empty_Desc = "Null/Error"
        Pcst_BST_1_NoOneIn_Desc = "No Value found"
         Pcst_BST_3_AllIn_Desc = "All submitted Values are inside Bitfield"
        Pcst_BST_4_Identic_Desc = "Seeked values are 1:1 identic to Bitfield"
'-----------
       Pcst_BST____0_Error_Name = "Pcst_BST____0_Error"
       Pcst_BST___0_MoreIn_Name = "Pcst_BST___0_MoreIn"
    Pcst_BST__0_EmptyBitField_Name = "Pcst_BST__0_EmptyBitField"
         Pcst_BST_0_Empty_Name = "Pcst_BST_0_Empty"
        Pcst_BST_1_NoOneIn_Name = "Pcst_BST_1_NoOneIn"
         Pcst_BST_3_AllIn_Name = "Pcst_BST_3_AllIn"
        Pcst_BST_4_Identic_Name = "Pcst_BST_4_Identic"
 
'----------
Init_PseudoConsts_Error:
 
  Select Case  Err
      
     Case 0
          
     Case Else       'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Init_PseudoConsts of Klassenmodul cBitSetInfo"
 
  End Select
 
End Sub
' Init_PseudoConsts
'
 
Private Function  RE_BitSetType( _
                                BitSetType_prm As BitSetType_en,
                                ReType_prm As RE_Type_en _
                             ) As String
 
'---------------------------------
'  Procedure : RE_BitSetType
'  Purpose   : Returns name and description of the EnumValues.
 
'----------
 
Dim _
     sReturn_lcl As  String, _
 sReturnName_lcl As  String, _
 sReturnDesc_lcl As  String
 
'----------
 
On Error  GoTo RE_BitSetType_Error
'----------
 
    Select Case  BitSetType_prm
   
        Case BST____0_Error
            sReturnDesc_lcl = Pcst_BST____0_Error_Desc
            sReturnName_lcl = Pcst_BST____0_Error_Name
             
        Case BST___0_MoreIn
            sReturnDesc_lcl = Pcst_BST___0_MoreIn_Desc
            sReturnName_lcl = Pcst_BST___0_MoreIn_Name
   
        Case BST__0_EmptyBitField
            sReturnDesc_lcl = Pcst_BST__0_EmptyBitField_Desc
            sReturnName_lcl = Pcst_BST__0_EmptyBitField_Name
   
        Case BST_0_Empty
            sReturnDesc_lcl = Pcst_BST_0_Empty_Desc
            sReturnName_lcl = Pcst_BST_0_Empty_Name
   
        Case BST_1_NoOneIn
            sReturnDesc_lcl = Pcst_BST_1_NoOneIn_Desc
            sReturnName_lcl = Pcst_BST_1_NoOneIn_Name
   
        Case BST_3_AllIn
            sReturnDesc_lcl = Pcst_BST_3_AllIn_Desc
            sReturnName_lcl = Pcst_BST_3_AllIn_Name
   
        Case BST_4_Identic
            sReturnDesc_lcl = Pcst_BST_4_Identic_Desc
            sReturnName_lcl = Pcst_BST_4_Identic_Name
         
        Case Else
            sReturnDesc_lcl = ""
            sReturnName_lcl = ""
   
    End Select
    '----------
 
    Select Case  ReType_prm
   
        Case Name_ReType
              sReturn_lcl = sReturnName_lcl
   
        Case Desc_ReType
              sReturn_lcl = sReturnDesc_lcl
         
        Case Else
              sReturn_lcl = ""
   
    End Select
 
    '----------
 
'----------
RE_BitSetType_Error:
 
  Select Case  Err
      
     Case 0
         RE_BitSetType = sReturn_lcl
     Case Else       'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure RE_BitSetType of Klassenmodul cBitSetInfo"
 
         RE_BitSetType = ""
  End Select
 
End Function
' RE_BitSetType
'