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