[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
'