A Wonderful, Magical Class Module
Imagine a single class module you can use for progressive combo box filtering, lazy loading combo boxes, AND multi-column filtering!
One of my favorite Simpsons moments is when Lisa decides to be a vegetarian. Homer teases her, pointing out all the great food she will be missing out on if she swears off meat:
[HOMER]: Lisa, honey, are you saying you're never going to eat any animal again? What about bacon?
[LISA]: No.
[HOMER]: Ham?
[LISA]: No.
[HOMER]: Pork chops?!
[LISA]: Dad! Those all come from the same animal.
[HOMER]: Haha. Yeah, right, Lisa. A wonderful, magical animal.
A Wonderful, Magical Class Module
In my presentation on Advanced Combo Box Techniques, my sample database included a class module named weComboLookup. I used that same multi-purpose class module to implement three different advanced techniques (the links below are teaser articles from before the presentation):
The Code: weComboLookup Class Module
In the sample database from my presentation, the class module has a couple of external dependencies. Namely, the two functions listed below are stored in separate code modules. I've included them at the bottom of my sample code in this article to make the class more portable.
To get started, copy and paste the code below into a new class module named weComboLookup. There are usage notes embedded in the module header comment.
I will be posting in-depth how-to articles in the future and will link to them here.
Option Compare Database
Option Explicit
'---------------------------------------------------------------------------------------
' Module : weComboLookup
' Author : Mike Wolfe <mike@nolongerset.com>
' Source : https://nolongerset.com/wecombolookup/
' Date : 2/16/2015 - 6/11/2021 01:18
' Purpose : This class module adds support for filtering combo boxes on multiple fields.
' Usage : In declarations section of Form module:
' Private cbFromAcctIDLookup As New weComboLookup
' Private cbToAcctIDLookup As New weComboLookup
' Private cbAddressLookup as New weComboLookup
'
' Private Sub Form_Open(Cancel As Integer)
' cbFromAcctIDLookup.Initialize Me.cbFromAcctID
' cbToAcctIDLookup.Initialize Me.cbToAcctID
' cbAddressLookup.Initialize Me.cbAddressLookup, 3
' cbAddressLookup.UnfilteredRowSource = "SELECT StreetName FROM Address " & _
' "WHERE StreetName Like '**'"
' End Sub
'
' : In RowSource, add one or more clauses like the following to the WHERE clause:
' MyField LIKE '**'
'
' Notes - RowSourceType must equal "Table/Query"
' - RowSource must have one or more "Like '**'" clauses
' - If RowSource is the name of a query, the query must have 1+ "Like '**'" clauses
' - The RowSource is checked each time the control is entered, so the class
' supports runtime updates made to the RowSource (e.g., "cascading" combos)
' - The RowSource is returned to its unfiltered state:
' o after it is updated (via the AfterUpdate event)
' o when the text is cleared via Escape-key-triggered Undo (via KeyUp event)
' o when the text is manually cleared by the user (via the OnChange event)
' - To enable lazy-loading for improved performance on large recordsets:
' o set the MinTextLength to 2 or higher
' o clear the RowSource property of the combo box control
' o set the UnfilteredRowSource property to a compatible SQL String or QueryDef name
' - According to JETSHOWPLAN, the "LIKE '**'" clause forces a table scan and
' does not benefit from the "MyField Like '*'" --> "MyField Is Not Null"
' optimization that a single asterisk Like clause receives; however, it
' does appear to perform all other indexing tasks first, so hopefully
' the performance will not be awful; that said, there is a tradeoff between
' providing an easy to implement feature and maximum performance; YMMV
' - DO NOT call the EnterCombo() function from the combo box's OnKeyUp event;
' doing so will prevent the Escape key from working properly if the text
' in the control box does not match any of the options
'---------------------------------------------------------------------------------------
Private WithEvents Ctl As Access.ComboBox
Private mCustomUnfilteredRowSrc As String
Private mOriginalRowSrc As String
Private mFilteredRowSrc As String
Private mMinTextLength As Integer
Private mFilter As String
Private mSearchFilteredRowSrc As String
Private mFilteringEnabled As Boolean
Private mControlName As String
Private mFormName As String
Private Type RowSrcInfo
HasFilterPlaceHolder As Boolean
HasContainsFilterInPlace As Boolean
SupportsContainsFilter As Boolean
SqlString As String
End Type
'---------------------------------------------------------------------------------------
' Procedure : Initialize
' Author : Mike
' Date : 2/16/2015
' Purpose : Initializes the object instance to provide enhanced filtering.
'---------------------------------------------------------------------------------------
'
Public Sub Initialize(ComboBoxControl As Access.ComboBox, Optional MinTextLength As Integer = 1)
Set Ctl = ComboBoxControl
Ctl.OnEnter = SetEventProc(Ctl.OnEnter)
Ctl.AfterUpdate = SetEventProc(Ctl.AfterUpdate)
Ctl.OnChange = SetEventProc(Ctl.OnChange)
Ctl.OnKeyUp = SetEventProc(Ctl.OnKeyUp)
mMinTextLength = MinTextLength
'we set the following module level variables to assist with debugging errors
On Error Resume Next
mControlName = Ctl.Name: Debug.Assert Len(mControlName) > 0
mFormName = Ctl.Parent.Name: Debug.Assert Len(mFormName) > 0
End Sub
Public Property Let UnfilteredRowSource(RowSrc As String)
mCustomUnfilteredRowSrc = RowSrc
End Property
Private Property Get UnfilteredRowSrc() As String
If Len(mCustomUnfilteredRowSrc) > 0 Then
If Len(Ctl.Text) >= mMinTextLength Then
UnfilteredRowSrc = mCustomUnfilteredRowSrc
Else
UnfilteredRowSrc = vbNullString
End If
ElseIf Not GetRowSrcInfo(mOriginalRowSrc).HasContainsFilterInPlace Then
UnfilteredRowSrc = mOriginalRowSrc
ElseIf Not GetRowSrcInfo(Ctl.RowSource).HasContainsFilterInPlace Then
UnfilteredRowSrc = Ctl.RowSource
Else
UnfilteredRowSrc = FilteredRowSrc("")
End If
End Property
'>>> RegExReplace("('\*)[^*]*(\*')", "AcctNum Like '**'", "$1Mike$2")
' AcctNum Like '*Mike*'
'>>> RegExReplace("('\*)[^*]*(\*')", "AcctNum Like '*John*'", "$1Mike$2")
' AcctNum Like '*Mike*'
'>>> RegExReplace("(""\*)[^*]*(\*"")", "AcctNum Like ""*John*"" OR ""*Tom*""", "$1Mike$2")
' AcctNum Like "*Mike*" OR "*Mike*"
Private Property Get FilteredRowSrc(FilterTxt As String) As String
Dim rsi As RowSrcInfo
If Len(mCustomUnfilteredRowSrc) > 0 Then
rsi = GetRowSrcInfo(mCustomUnfilteredRowSrc)
Else
rsi = GetRowSrcInfo(Ctl.RowSource)
End If
Debug.Assert rsi.SupportsContainsFilter
Dim SqlBase As String
SqlBase = rsi.SqlString 'may not match Ctl.RowSource if GetRowSrcInfo calls itself recursively
Dim CleanTxt As String
CleanTxt = Replace(FilterTxt, "*", "[*]")
Dim EscapedSingleQuotes As String
EscapedSingleQuotes = Replace(CleanTxt, "'", "''")
FilteredRowSrc = RegExReplace("('\*)[^*]*(\*')", SqlBase, "$1" & EscapedSingleQuotes & "$2")
Dim EscapedDoubleQuotes As String
EscapedDoubleQuotes = Replace(CleanTxt, """", """""")
FilteredRowSrc = RegExReplace("(""\*)[^*]*(\*"")", FilteredRowSrc, "$1" & EscapedDoubleQuotes & "$2")
End Property
'---------------------------------------------------------------------------------------
' Procedure : GetRowSrcInfo
' Author : Mike
' Date : 2/17/2015
' Purpose : Returns info about a RowSrc's "contains" filter support and its current state.
'---------------------------------------------------------------------------------------
'
Private Function GetRowSrcInfo(RowSrc As String) As RowSrcInfo
Dim rsi As RowSrcInfo
rsi.SqlString = RowSrc
rsi.HasFilterPlaceHolder = (InStr(RowSrc, """**""") > 0) Or _
(InStr(RowSrc, "'**'") > 0)
'We will assume that if there is at least one FilterPlaceHolder, then
' for our purposes, we assume that there is no
' "contains filter" (e.g., "LIKE '*sometext*'") in place
If Not rsi.HasFilterPlaceHolder Then
Dim OpenFilterPos As Long, CloseFilterPos As Long
OpenFilterPos = InStr(RowSrc, """*")
If OpenFilterPos > 0 Then
CloseFilterPos = InStr(RowSrc, "*""")
End If
rsi.HasContainsFilterInPlace = (OpenFilterPos > 0 And CloseFilterPos > OpenFilterPos)
If Not rsi.HasContainsFilterInPlace Then
OpenFilterPos = InStr(RowSrc, "'*")
If OpenFilterPos > 0 Then
CloseFilterPos = InStr(OpenFilterPos, RowSrc, "*'")
End If
rsi.HasContainsFilterInPlace = (OpenFilterPos > 0 And CloseFilterPos > OpenFilterPos)
End If
End If
rsi.SupportsContainsFilter = (rsi.HasFilterPlaceHolder Or rsi.HasContainsFilterInPlace)
If Not rsi.SupportsContainsFilter Then
'Allow for RowSource's that are the names of query definitions
On Error Resume Next
Dim QrySql As String
QrySql = CurrentDb.QueryDefs(RowSrc).SQL
On Error GoTo 0
If Len(QrySql) > 0 Then rsi = GetRowSrcInfo(QrySql)
End If
GetRowSrcInfo = rsi
End Function
'---------------------------------------------------------------------------------------
' Procedure : MinTextLength
' Author : Mike
' Date : 2/16/2015
' Purpose : Sets the minimum length for a user-entered string before filtering occurs.
' Notes - Set to 1 so that filtering begins as soon as the user enters text.
' - Set to 3 so that filtering does not happen until at least 3 characters are entered.
' - If performance is slow, the MinTextLength may be increased so that fewer
' results are returned and filtering does not happen as frequently.
'---------------------------------------------------------------------------------------
'
Public Property Let MinTextLength(Value As Integer)
mMinTextLength = Value
End Property
Public Property Get MinTextLength() As Integer
MinTextLength = mMinTextLength
End Property
'---------------------------------------------------------------------------------------
' Procedure : Ctl_AfterUpdate
' Author : Mike
' Date : 2/16/2015
' Purpose : After the user makes a selection, we restore the default Row Source so that
' all options are available the next time the user edits the control.
'---------------------------------------------------------------------------------------
'
Private Sub Ctl_AfterUpdate()
If Not mFilteringEnabled Then Exit Sub
Ctl.RowSource = UnfilteredRowSrc
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Ctl_Change
' Author : Mike
' Date : 2/16/2015
' Purpose : As the user edits the field, the RowSource is dynamically updated to
' show the matching records.
'---------------------------------------------------------------------------------------
'
Private Sub Ctl_Change()
If Not mFilteringEnabled Then Exit Sub
Dim SelectionLength As Integer
SelectionLength = GetSelLength(Ctl)
'If .AutoExpand is True, then some of the text in the combo box may be autocompleted;
' for filtering purposes, we only want to consider the user-entered text
Dim UserEnteredText As String
If SelectionLength > 0 Then
'If user is using the up and down arrow keys to choose an option
' in the dropdown portion of the combo box, we should let
' them do that without interruption from us
If SelectionLength = Len(Ctl.Text) Then Exit Sub
If Len(Ctl.Text) > 0 Then Ctl.Dropdown
UserEnteredText = Left(Ctl.Text, Len(Ctl.Text) - SelectionLength)
Else
UserEnteredText = Ctl.Text
End If
If Len(UserEnteredText) < Me.MinTextLength Then
Dim UnfilteredRowSource As String
UnfilteredRowSource = UnfilteredRowSrc
If Ctl.RowSource <> UnfilteredRowSource Then Ctl.RowSource = UnfilteredRowSource
Exit Sub
End If
Dim SavePos As Integer: SavePos = Ctl.SelStart
Ctl.RowSource = FilteredRowSrc(UserEnteredText)
Ctl.SetFocus
Ctl.SelStart = SavePos
Ctl.SelLength = SelectionLength
Ctl.Dropdown
End Sub
'Avoids error 2185 "Can't reference prop unless the ctl has the focus"
Private Function GetSelLength(Ctl As Control) As Integer
On Error Resume Next
GetSelLength = Ctl.SelLength
End Function
' Developer convenience function to prevent accidentally obliterating custom form/control properties.
Private Function SetEventProc(EventProp As String, Optional OverRidableText As String) As String
If Len(EventProp) = 0 Or EventProp = "[Event Procedure]" Or EventProp = OverRidableText Then
SetEventProc = "[Event Procedure]"
Else
Throw EventProp & " must be changed to '[Event Procedure]'"
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : Ctl_Enter
' Author : Mike
' Date : 2/17/2015
' Purpose : The RowSource may have changed due to external processing, so we do another check
'---------------------------------------------------------------------------------------
'
Private Sub Ctl_Enter()
Debug.Assert Ctl.RowSourceType = "Table/Query"
If Len(mCustomUnfilteredRowSrc) > 0 Then
'A custom unfiltered row source may be passed to the class for improved performance
' with large recordsets (see notes in class header)
mOriginalRowSrc = mCustomUnfilteredRowSrc
Else
mOriginalRowSrc = Ctl.RowSource
End If
Dim rsi As RowSrcInfo
rsi = GetRowSrcInfo(mOriginalRowSrc)
If Not rsi.SupportsContainsFilter Then
mFilteringEnabled = False
'Alert the developer but not the user
Debug.Assert False 'Throw "RowSource does not support advanced filtering: {0}", Ctl.RowSource
Else
mFilteringEnabled = True
End If
End Sub
' Handle user clearing a field by pressing the Escape key
Private Sub Ctl_KeyUp(KeyCode As Integer, Shift As Integer)
If Not mFilteringEnabled Then Exit Sub
If KeyCode = vbKeyEscape And Len(Ctl.Text) = 0 Then Ctl_Change
End Sub
Sub Throw(Msg As String)
'Dummy implementation (follow link below for full implementation)
'https://nolongerset.com/throwing-errors-in-vba/
MsgBox Msg, vbExclamation, "Error!"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : RegExReplace
' Author : Mike Wolfe <mike@nolongerset.com>
' Source : https://nolongerset.com/now-you-have-two-problems/
' Date : 11/4/2010
' Purpose : Attempts to replace text in the TextToSearch with text and back references
' from the ReplacePattern for any matches found using SearchPattern.
' Notes - If no matches are found, TextToSearch is returned unaltered. To get
' specific info from a string, use RegExExtract instead.
'>>> RegExReplace("(.*)(\d{3})[\)\s.-](\d{3})[\s.-](\d{4})(.*)", "My phone # is 570.555.1234.", "$1($2)$3-$4$5")
'My phone # is (570)555-1234.
'---------------------------------------------------------------------------------------
'
Private Function RegExReplace(SearchPattern As String, TextToSearch As String, ReplacePattern As String, _
Optional GlobalReplace As Boolean = True, _
Optional IgnoreCase As Boolean = False, _
Optional MultiLine As Boolean = False) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = MultiLine
.Global = GlobalReplace
.IgnoreCase = IgnoreCase
.Pattern = SearchPattern
End With
RegExReplace = RE.Replace(TextToSearch, ReplacePattern)
End Function
Referenced articles
Advanced Combo Box Techniques
A list of resources and further reading to support my presentation on Advanced Combo Box Techniques.
Mike Wolfe
Progressive Combo Box Filtering
Autocomplete for combo boxes with hundreds of thousands of entries? It’s possible with the progressive filtering technique.
Mike Wolfe
Lazy Loading Combo Boxes
Don’t load tens of thousands of records into a combo box. Instead, wait for the user to start typing, and then load only what they need.
Mike Wolfe
Multi-Column Progressive Combo Box Filtering
You, too, can learn to filter your combo boxes by every visible column.
Mike Wolfe
Throwing Errors in VBA
Introducing a frictionless alternative to Err.Raise.
Mike Wolfe
Now you have two problems
Some people, when confronted with a problem, think “I know, I’ll use regular expressions.” Now they have two problems. --Jamie Zawinski
Mike Wolfe
