A Wonderful, Magical Class Module

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.

The Throw function
The RegExReplace function

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