Auto Expand / Search in an Access listbox

Access comboxes have a very useful ability to search for items as you type in data, e.g. if a combobox has the following items:

Cook Clay​ Crisp​ Richardson

and you type in "cr" then "Crisp" will be selected. In order for this to happen you just need to set the combobox's Auto Expand property to True (and sort the combobox's contents in order). However, there is no equivalent property for Access listboxes. There is, however, a work around. If you create a Class called, say, "ListboxSearch", enter the following code into it and follow the instructions in the comments in its header, you will find that if your listbox has the same items as the combobox above, typing in "cr" will take you to "Crisp" rather than to "Richardson" as would normally happen : ​​

Option Compare Database

Option Explicit

'===================================================

'NOTE Need the following code in the form's header

'Dim mlb As ListboxSearch

'and the following in the form's Load event:

'Set mlb = New ListboxSearch

'mlb.Setup SearchForm:=Me, SearchListbox:=(listbox to search), FieldToSearchOn: = (search-field name)

'and the following in its Form_Unload

'Set mlb = Nothing

'===================================================

'Further enhancements?

'Could return the value of mstrKeysEntered to the form to show in a label or textbox?

Private mstrKeysEntered As String

Private mListbox As Listbox

Private WithEvents mForm As Form

Private mstrFieldToSearchOn As String

Private Const mconQuotes As String = """"

Private mstrAppName As String

Dim mrst As DAO.Recordset

Public Function Setup(ByRef SearchForm As Form, _

ByRef SearchListbox As Listbox, _

FieldToSearchOn As String, _

Optional AppName As String = "")

Dim db As DAO.Database

Set mForm = SearchForm

mForm.KeyPreview = True

Set mListbox = SearchListbox

If mForm.OnKeyPress = "" Then

mForm.OnKeyPress = "[Event Procedure]"

End If

mstrFieldToSearchOn = FieldToSearchOn

Set db = CurrentDb

Set mrst = db.OpenRecordset(mListbox.RowSource).OpenRecordset(dbOpenSnapshot)

mstrAppName = AppName

On Error Resume Next

Set db = Nothing

End Function

Private Sub Class_Terminate()

On Error Resume Next

mrst.Close

Set mrst = Nothing

End Sub

Private Sub mForm_KeyPress(KeyAscii As Integer)

Select Case KeyAscii

Case 8

'Backspace

If Len(mstrKeysEntered) > 0 Then

mstrKeysEntered = Left$(mstrKeysEntered, Len(mstrKeysEntered) - 1)

End If

Case 27

'Esc

mstrKeysEntered = ""

Case Else

mstrKeysEntered = mstrKeysEntered & Chr$(KeyAscii)

mrst.FindFirst mstrFieldToSearchOn & " Like " _

& mconQuotes & mstrKeysEntered & "*" & mconQuotes

If Not mrst.NoMatch Then

With mListbox

'Allow for whether Column Headers are in use.

.Selected(mrst.AbsolutePosition _

+ Abs(.ColumnHeads = True)) = True

.Value = .ItemData(mrst.AbsolutePosition _

+ Abs(.ColumnHeads = True))

End With

Else

MsgBox "No such value found. Please start again", , mstrAppName

mstrKeysEntered = ""

End If

End Select

Debug.Print KeyAscii, mstrKeysEntered

KeyAscii = 0

End Sub​