Option Explicit
'ExampleClass Class module
Public Field1 As String
Public Status As Long
Public DueDate As Date
Private Sub Class_Initialize()
Field1 = Chr(Int(Rnd * 3) + 65) & Chr(Int(Rnd * 3) + 65) & Chr(Int(Rnd * 3) + 65)
Status = Int(Rnd * 6)
DueDate = Date() + Int(Rnd * 101)
End Sub
Public Function FilterCollection(parmCol As Collection, parmFilter As String) As Collection
Dim oCC As ExampleClass
Dim lngLoop As Long
Dim oVBS As Object 'alternatively New ScriptControl if Reference added
Dim BS As New clsBuildString 'see Fast Concatenate article A_8311.html
Dim colFiltered As New Collection
Set oVBS = CreateObject("ScriptControl")
BS.Add "Function CCFilter(parmCC)"
BS.Add " With parmCC"
BS.Add " CCFilter = " & parmFilter
BS.Add " End With"
BS.Add "End function"
BS.Add "Public Function IsLike(parmString, parmPattern)"
BS.Add " Dim RegExp"
BS.Add " Set RegExp = CreateObject(""vbscript.RegExp"")" 'version: VBScript_RegExp_55
BS.Add " RegExp.Pattern = parmPattern"
BS.Add " IsLike = RegExp.Test(parmString)"
BS.Add "End Function"
BS.Delim = vbCrLf
oVBS.Language = "VBScript"
oVBS.AddCode BS.Text
For Each oCC In parmCol
lngLoop = lngLoop + 1
If oVBS.Run("CCFilter", oCC) = True Then
'Debug.Print lngLoop, oCC.Status, oCC.Field1, oCC.DueDate 'for debugging/playing
colFiltered.Add oCC
End If
Next
Set FilterCollection = colFiltered
End Function
.Field1
.Style
.DueDate
If you want to make this a bit more familiar, you can use the square bracket convention you might be used to in your database applications.
.[Field1]
.[Style]
.[DueDate]
A Convenience Avoided
Replace(Replace(FilterString, "[", ".["), "..[", ".[")
Like RegExp
___________ ____________
[!charlist] [^charlist]
# \d
? [\s\S]
* [\s\S]*
The up-side of creating the
IsLike() function is that we can use any RegExp pattern, which provides more powerful pattern matching than the VB/VBA
Like operator.
Public Sub main()
Dim colCC As New Collection
Dim oCC As ExampleClass
Dim lngLoop As Long
Dim oVBS As Object 'alternatively New ScriptControl if reference added
Dim varItem As Variant
Dim strFilter As String
Set oVBS = CreateObject("ScriptControl")
For lngLoop = 1 To 40
Set oCC = New ExampleClass
colCC.Add oCC
Next
'Different filters to test
' strFilter = "(.[Field1] = ""ABC"") AND (.[Status] >=2)"
' Debug.Print "***", strFilter
' strFilter = "(instr(2, .[Field1], ""AA"")<>0 )"
' Debug.Print "***", strFilter
' strFilter = "(Right(.[Field1],2) = ""AA"") "
' Debug.Print "***", strFilter
' strFilter = "(.[DueDate] >= #1/15/2012#) And (.[DueDate] < #2/1/2012#) "
' Debug.Print "***", strFilter
' strFilter = "(.[Field1] = ""ABC"") AND (.[Status] >=2)"
' Debug.Print "***", strFilter
strFilter = "IsLike(.[Field1] , ""[\s\S]CB"")"
Debug.Print "***", strFilter
For Each oCC In FilterCollection(colCC, "IsLike(.[Field1] , ""[\s\S]CB"")")
Debug.Print oCC.Status, oCC.Field1, oCC.DueDate
Next
Set colCC = Nothing
End Sub
*** (.[Field1] = "ABC") AND (.[Status] >=2)
19 2 ABC 2/6/2012
*** (instr(2, .[Field1], "AA")<>0 )
3 3 CAA 12/24/2011
8 1 AAA 11/16/2011
13 1 BAA 2/7/2012
28 4 CAA 11/24/2011
*** (Right(.[Field1],2) = "AA")
3 3 CAA 12/24/2011
8 1 AAA 11/16/2011
13 1 BAA 2/7/2012
28 4 CAA 11/24/2011
*** (.[DueDate] >= #1/15/2012#) And (.[DueDate] < #2/1/2012#)
1 1 CAB 1/25/2012
5 5 CCA 1/16/2012
7 1 BCA 1/25/2012
12 5 BCA 1/16/2012
16 4 CAB 1/16/2012
18 0 AAB 1/26/2012
27 5 BAC 1/15/2012
33 1 AAC 1/16/2012
39 1 CBC 1/28/2012
*** IsLike(.[Field1] , "[\s\S]CB") -- equivalent to Like "?CB"
16 2 BCB 2/2/2012
23 3 CCB 12/31/2011
29 4 CCB 1/17/2012
30 1 ACB 12/29/2011
31 0 CCB 1/4/2012
Option Explicit
Private m_col As Collection
Public Function FilteredItems(ByVal parmFilter As String) As Collection
Dim oCC As Variant
Dim lngLoop As Long
Dim oVBS As Object 'alternatively New ScriptControl if Reference added
Dim BS As New clsBuildString 'see Fast Concatenate article A_8311.html
Dim colFiltered As New Collection
Set oVBS = CreateObject("ScriptControl")
BS.Add "Function CCFilter(parmCC)"
BS.Add " With parmCC"
BS.Add " CCFilter = " & parmFilter
BS.Add " End With"
BS.Add "End function"
BS.Add "Public Function IsLike(parmString, parmPattern)"
BS.Add " Dim RegExp"
BS.Add " Set RegExp = CreateObject(""vbscript.RegExp"")" 'version: VBScript_RegExp_55
BS.Add " RegExp.Pattern = parmPattern"
BS.Add " IsLike = RegExp.Test(parmString)"
BS.Add "End Function"
BS.Delim = vbCrLf
oVBS.Language = "VBScript"
oVBS.AddCode BS.Text
For Each oCC In m_col
lngLoop = lngLoop + 1
If oVBS.Run("CCFilter", oCC) = True Then
colFiltered.Add oCC
End If
Next
Set FilteredItems = colFiltered
End Function
oVBS.Language = "VBScript"
oVBS.AddCode "Function CCFilter(parmCC)" & vbCrLf & _
" With parmCC" & vbCrLf & _
" CCFilter = " & parmFilter & vbCrLf & _
" End With" & vbCrLf & _
"End function" & vbCrLf & _
"Public Function IsLike(parmString, parmPattern)" & vbCrLf & _
" Dim RegExp" & vbCrLf & _
" Set RegExp = CreateObject(""vbscript.RegExp"")" & vbCrLf & _
" RegExp.Pattern = parmPattern" & vbCrLf & _
" IsLike = RegExp.Test(parmString)" & vbCrLf & _
"End Function"
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)