Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Enum e_BV_Filt_Logic
Or_ = 0 ' O(79)
And_ = 1 ' A(65)
End Enum
'==================================================================================================
Enum e_BV_Filt_Oper
Less = 1 ' <(60) Min
Equal = 2 ' =(61)
More = 4 ' >(62)
InStr_ = 8 ' I(73)
RegExp = 16 ' R(82) Max
CaseIgnore = 32 ' C(67)
Basic = 64 '
Extended = 128 '
Like_ = 256 ' L(76)
Not_ = 512 ' N(78)
End Enum
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Function IsIntPosit(ByVal vIn, vIntOut, Optional AllowZero As Boolean) As Boolean
If Not IsNumeric(vIn) Then Exit Function
vIn = --vIn
If (vIn <> Fix(vIn)) Then Exit Function
If AllowZero Then
If (vIn < 0) Then Exit Function
Else
If (vIn < 1) Then Exit Function
End If
vIntOut = vIn: IsIntPosit = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Function ReqFix(sIn$, sOutIn$, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, i&
Static st&, REa As RegExp, REl As RegExp, REr As RegExp, REd As RegExp
If (st = 0) Then
st = 1
Set REa = New RegExp: REa.Global = True: REa.Pattern = "([()])"
Set REl = New RegExp: REl.Global = True: REl.Pattern = "(\d)(\D)"
Set REr = New RegExp: REr.Global = True: REr.Pattern = "(\D)(\d)"
Set REd = New RegExp: REd.Global = True: REd.Pattern = "([()]) ([()])"
End If
s = UCase$(BV.Trim(sIn))
If (s Like "*[! ()0-9<=>ACILNOR]*") Then
If MsgFalse Then MsgBox "RequestString" & vbLf & "«" & sIn & "»" & vbLf & vbLf & "contain BAD Symbol!", vbCritical, "BV_Filter_GetParams(ReqFix)"
Exit Function
End If
Do
i = InStr(s, "<>"): If (i = 0) Then Exit Do
Mid$(s, i, 2) = "N="
Loop
s = REa.Replace$(s, " $1 ")
s = REl.Replace$(s, "$1 $2")
s = REr.Replace$(s, "$1 $2")
s = BV.Trim(s)
s = REd.Replace$(s, "$1$2")
If MsgTrue Then MsgBox "RequestString" & vbLf & "«" & sIn & "»" & vbLf & vbLf & "was succsessfully transformed to" & vbLf & "«" & s & "»", vbInformation, "BV_Filter_GetParams(ReqFix)"
ReqFix = True: sOutIn = s
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_ReqFix()
Dim s$
s = "( (2=>1)a(4l2) )o( (2<=3)a(5nl4) )"
ReqFix s, s, True, True ' «(( 2 => 1 ) A ( 4 L 2 )) O (( 2 <= 3 ) A ( 5 NL 4 ))»
End Sub
'==================================================================================================
'==================================================================================================
Private Function UnCode(sIn$, vOut&, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&, c&, p&
Static st&, a&()
If (st = 0) Then
st = 1: ReDim a(82)
For n = 1 To UBound(a)
a(n) = -1
Next n
a(60) = 1 ' <
a(61) = 2 ' =
a(62) = 4 ' >
a(65) = 1 ' A: And(Logic)
a(67) = 32 ' C: CaseIgnore
a(73) = 8 ' I: InStr
a(76) = 256 ' L: Like
a(78) = 512 ' N: Not
a(79) = 0 ' O: Or(Logic)
a(82) = 16 ' R: RegExp
End If
If (sIn = "") Then
If MsgFalse Then MsgBox "Code is EMPTY!", vbCritical, "BV_Filter_GetParams(UnCode)"
Exit Function
End If
vOut = 0: p = -1
On Error Resume Next
For n = 1 To Len(sIn)
c = BV.UnicodeCharCodeGet(sIn, n): p = a(c)
If (p = -1) Then
If MsgFalse Then MsgBox "Char «" & ChrW$(c) & "» is NOT Correct!", vbCritical, "BV_Filter_GetParams(UnCode)"
Exit Function
End If
vOut = vOut + p: p = -1
Next n
UnCode = True
If MsgTrue Then MsgBox "Code «" & sIn & "» is Correct and calculate to number «" & vOut & "»", vbInformation, "BV_Filter_GetParams(UnCode)"
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_UnCode()
Dim n&
UnCode "NL", n, True, True
End Sub
'==================================================================================================
'==================================================================================================
' Checks
'==================================================================================================
Private Function Ch1_Logic(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not UnCode(s, n, , MsgFalse) Then GoTo er
If ((n <> 0) And (n <> 1)) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct Logic «" & s & "(" & n & ")»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch1_Logic)"
vOut = n: Ch1_Logic = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD Logic «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch1_Logic)"
End Function
'==================================================================================================
Private Function Ch2_Brackets(aReq, nPos&, vOut, Optional RightBracket As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$
s = aReq(nPos)
If RightBracket Then
If (s Like "*[!)]*") Then GoTo er
Else
If (s Like "*[!(]*") Then GoTo er
End If
If MsgTrue Then MsgBox "Argument «sReq» contain Correct Bracket(s) «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch2_Brackets)"
vOut = s: Ch2_Brackets = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD Bracket(s) «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch2_Brackets)"
End Function
'==================================================================================================
Private Function Ch3_ColNum(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not IsIntPosit(s, n) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct ColNum «" & n & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch3_ColNum)"
vOut = n: Ch3_ColNum = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD ColNum «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch3_ColNum)"
End Function
'==================================================================================================
Private Function Ch4_ParamCode(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not UnCode(s, n, , MsgFalse) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct CodeParam «" & s & "(" & n & ")»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch4_ParamCode)"
vOut = n: Ch4_ParamCode = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD CodeParam «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch4_ParamCode)"
End Function
'==================================================================================================
Private Function Ch5_ArrIndex(aReq, nPos&, vOut, aVal, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&, UBnd&
s = aReq(nPos): If Not IsIntPosit(s, n) Then GoTo er
UBnd = UBound(aVal): If (n > UBnd) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct ArrIndex «" & n & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch5_ArrIndex)"
vOut = aVal(n): Ch5_ArrIndex = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD ArrIndex «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch5_ArrIndex)"
End Function
'==================================================================================================
'==================================================================================================
' Prepare
'==================================================================================================
Private Function Prepare(sReq_InOut$, aSpl_Out, DivBy236&, a1D_ValForReq, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
If Not ReqFix(sReq_InOut, sReq_InOut, , MsgFalse) Then Exit Function
If (DivBy236 = 6) Then sReq_InOut = "A " & sReq_InOut
aSpl_Out = Split(sReq_InOut): BV.ArrayReDim aSpl_Out, 1
If ((UBound(aSpl_Out) Mod DivBy236) <> 0) Then
If MsgFalse Then MsgBox "Argument «sReq» is NOT Divisible by " & DivBy236 & "!" & vbLf & "«" & sReq_InOut & "»", vbCritical, "BV_Filter_GetParams_ByStr(Prepare)"
Exit Function
End If
If Not IsArray(a1D_ValForReq) Then a1D_ValForReq = Array(a1D_ValForReq)
BV.ArrayReDim a1D_ValForReq, 1
Prepare = True
If MsgTrue Then MsgBox "Argument «sReq» was successfully Prepared" & vbLf & vbLf & "«" & sReq_InOut & "»", vbInformation, "BV_Filter_GetParams_ByStr(Prepare)"
End Function
'==================================================================================================
'==================================================================================================
' GetParams_ByStr
'==================================================================================================
' Rule: (Col2 = "Dell" And Col4 Like "LGA 1*") Or (Col2 = "HPE" And Col5 Not Like "2*")
' Tens: 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 2 2 Total: 23 + 1 = 24. 24 Mod 6 = 0. 24 / 6 = 4 Rows in a2D_Par_Out
' Units: 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3
' sReq(Perfect): "(( 2 = 1 ) A ( 4 L 2 )) O (( 2 = 3 ) A ( 5 NL 4 ))"
' sReq(can be): "( (2=1)a(4l2) )o( (2=3)a(5nl4) )"
' a1D_ValForReq: Array("Dell", "LGA 1*", "HPE", "2*")
' Tens: 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 Total: 24
' Units: 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4
' sReq(transform): "A (( 2 => 1 ) A ( 4 L 2 )) O (( 2 <= 3 ) A ( 5 NL 4 ))"
Function BV_Filter_GetParams_ByStr(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, spl, s$, r&, n&, p&, UBnd&
If Not Prepare(sReq, spl, 6, a1D_ValForReq, , MsgFalse) Then Exit Function
ReDim a2D_Par_Out(UBound(spl) / 6, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
If Not Ch1_Logic(spl, n + 1, a2D_Par_Out(r, 1), , MsgFalse) Then Exit Function
If Not Ch2_Brackets(spl, n + 2, a2D_Par_Out(r, 2), False, , MsgFalse) Then Exit Function
If Not Ch3_ColNum(spl, n + 3, a2D_Par_Out(r, 3), , MsgFalse) Then Exit Function
If Not Ch4_ParamCode(spl, n + 4, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 5, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
If Not Ch2_Brackets(spl, n + 6, a2D_Par_Out(r, 6), True, , MsgFalse) Then Exit Function
n = n + 6
Next r
BV_Filter_GetParams_ByStr = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: ( (Col2 = "Dell") And (Col4 Like "LGA 1*") ) Or ( (Col2 = "HPE") And (Col5 Not Like "2*") )
Private Sub Test_BV_Filter_GetParams_ByStr()
Dim a, s$
s = "( (2=1)a(4l2) )o( (2=3)a(5nl4) )"
a = Array("Dell", "LGA 1*", "HPE", "2*")
If Not BV_Filter_GetParams_ByStr(a, s, a, True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
' Rule: Col2 = "Dell" And Col4 Like "LGA 1*"
' sReq(Perfect): "2 = 1 4 L 2" ' Must be Divisible by 3
' sReq(can be): "2=1 4L2"
Function BV_Filter_GetParams_ByStr_OneLogic(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional UseOR As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim spl, s$, r&, n&, logic&
If Not Prepare(sReq, spl, 3, a1D_ValForReq, , MsgFalse) Then Exit Function
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim a2D_Par_Out(UBound(spl) / 3, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
a2D_Par_Out(r, 1) = logic
a2D_Par_Out(r, 2) = "("
If Not Ch3_ColNum(spl, n + 1, a2D_Par_Out(r, 3), , MsgFalse) Then Exit Function
If Not Ch4_ParamCode(spl, n + 2, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 3, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
a2D_Par_Out(r, 6) = ")"
n = n + 3
Next r
BV_Filter_GetParams_ByStr_OneLogic = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr_OneLogic"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: Col2 = "Dell" And Col4 Like "LGA 1*"
Private Sub Test_BV_Filter_GetParams_ByStr_OneLogic()
Dim a, s$
s = "2=1 4L2"
a = Array("Dell", "LGA 1*")
If Not BV_Filter_GetParams_ByStr_OneLogic(a, s, a, , True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
' Rule: Col2 = "Dell" And Col2 Like "LGA 1*"
' sReq(Perfect): "= 1 L 2" ' Must be Divisible by 2
' sReq(can be): "=1 L2"
Function BV_Filter_GetParams_ByStr_OneLogic_OneCol(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional UseOR As Boolean, Optional ColNum& = 1, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim spl, s$, r&, n&, logic&
If Not Prepare(sReq, spl, 2, a1D_ValForReq, , MsgFalse) Then Exit Function
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim a2D_Par_Out(UBound(spl) / 2, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
a2D_Par_Out(r, 1) = logic
a2D_Par_Out(r, 2) = "("
a2D_Par_Out(r, 3) = ColNum
If Not Ch4_ParamCode(spl, n + 1, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 2, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
a2D_Par_Out(r, 6) = ")"
n = n + 2
Next r
BV_Filter_GetParams_ByStr_OneLogic_OneCol = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr_OneLogic_OneCol"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: Col2 = "Dell" And Col2 Like "LGA 1*"
Private Sub Test_BV_Filter_GetParams_ByStr_OneLogic_OneCol()
Dim a, s$
s = "=1 L2"
a = Array("Dell", "LGA 1*")
If Not BV_Filter_GetParams_ByStr_OneLogic_OneCol(a, s, a, , 2, True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = "'" & s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function BV_Filter_Run(aFilt_In, aParam_In, aOutIn, Optional RetIndexes As Boolean, Optional Msg–1_Err As Boolean, Optional Msg0_Empty As Boolean, Optional Msg1_Full As Boolean) As Long
Dim rOld&, rNew&
rOld = UBound(aFilt_In, 1) - LBound(aFilt_In, 1) + 1
On Error Resume Next
BV.ArrayFilterV aFilt_In, aParam_In, RetIndexes, aOutIn
If (Err.Number <> 0) Then
If Msg–1_Err Then MsgBox "UnCorrect condition(s)!", vbCritical, "BV_Filter_Run"
Err.Clear: BV_Filter_Run = -1: Exit Function
End If
rNew = UBound(aOutIn, 1) - LBound(aOutIn, 1) + 1
If (rNew < 1) Then
If Msg0_Empty Then MsgBox "Can't Find any Row!", vbExclamation, "BV_Filter_Run"
Exit Function
End If
BV_Filter_Run = 1
If Msg1_Full Then MsgBox "Filter Rows: " & Format$(rNew, "#,#") & " out of " & Format$(rOld, "#,#"), vbInformation, "BV_Filter_Run"
End Function
'==================================================================================================
|
