The following images show a Find As You Type (FAYT) multiselect listbox. This allows you to filter the list and choose multiple selections. Then you can expand or do another filter and still maintain your selections.
Here are five images 1-3 shows the filter, 4 the selection, and 5 the unselection.
Now the code is all written is a class module. So anyone can instantiate this funtionality with a single line of code. Just drop the classes into class modules with the correct names.
Here is how you use the code in a form module. You need a textbox and a listbox on your form. In my example I put the textbox above the listbox.
Code:
Option Compare Database
Option Explicit
Public faytLst As New FindAsYouTypeListBox
Private Sub Form_Load()
faytLst.Initialize Me.lstSearch, Me.txtSearch, 1, True
End Sub
That is all the code you need to write all of the action is contained in the class modules.
Where
lstSearch is the name of my listbox
txtSearch is the name of my unbound textbox
1 is the column to search (1 have a hidden column that stored the primary keys) and columns are zero based. So my hidden column is 0, the visible column is 1. If you do not have a hidden column then the first column is 0.
the Last parameter specifies if you want to search from the beginning of a string or within a string. So if you type Ch it will return only things starting with Ch not ones with ch somewhere else.
Now these are the classes. No I did not make this just for this example. I have a library of custom classes so if I want specific functionality I can turn any combo or listbox into a find as you type and many other things.
Class module must be named: FindAsYouTypeListBox
Code:
'Class Module Name: FindAsYouTypeListBox
'Purpose: Turn any Listbox into a "Find As You Type" listbox
'Created by: MajP
'Dumb this down to be a single column listbox showing the value
Private WithEvents mListbox As Access.ListBox
Private WithEvents mForm As Access.Form
Private WithEvents mSearchForm As Access.Form
Private WithEvents mTextBox As Access.TextBox
Private mColumnToSearch As Integer
Private mFilterFromStart As Boolean
Private mSearchAllFields As Boolean
Private mRsOriginalList As DAO.Recordset
Private mUniqueItems As New UniqueStringCollection
Public Sub Initialize(theListBox As Access.ListBox, theTextBox As Access.TextBox, Optional ColumnToSearch As Integer = 0, Optional FilterFromStart = True)
'The column to search is 0 if the first column and 1 if second
'Often the first column is hidden
On Error GoTo errLabel
If Not theListBox.RowSourceType = "Table/Query" Then
MsgBox "This class will only work with a ListBox that uses a Table or Query as the Rowsource"
Exit Sub
End If
Set mListbox = theListBox
Set mForm = theListBox.Parent
Set mTextBox = theTextBox
mColumnToSearch = ColumnToSearch
mFilterFromStart = FilterFromStart
mForm.OnCurrent = "[Event Procedure]"
mTextBox.OnGotFocus = "[Event Procedure]"
mTextBox.OnChange = "[Event Procedure]"
mListbox.AfterUpdate = "[Event Procedure]"
Set mRsOriginalList = mListbox.Recordset.Clone
Exit Sub
errLabel:
MsgBox Err.Number & " " & Err.Description
End Sub
'**************************** Properties
Public Property Get FilterFromStart() As Boolean
FilterFromStart = mFilterFromStart
End Property
Public Property Let FilterFromStart(ByVal blnFilterFromStart As Boolean)
mFilterFromStart = blnFilterFromStart
End Property
Public Property Get ColumnToSearch() As Integer
ColumnToSearch = mColumnToSearch
End Property
Public Property Let ColumnToSearch(ByVal theColumnToSearch As Integer)
mColumnToSearch = theColumnToSearch
End Property
Public Property Get FieldToSearch() As String
FieldToSearch = Me.ListBox.Recordset.Fields(Me.ColumnToSearch).Name
End Property
Public Property Get ListBox() As Access.ListBox
Set ListBox = mListbox
End Property
Public Property Get UniqueItems() As UniqueStringCollection
Set UniqueItems = mUniqueItems
End Property
'******************** Private Methods
Private Sub FilterList()
On Error GoTo errLable
Dim rsTemp As DAO.Recordset
Dim strFilter As String
If Not Trim(mTextBox.Text & " ") = "" Then
strFilter = getFilter(mTextBox.Text)
Else
Call unFilterList
End If
Set rsTemp = mRsOriginalList.OpenRecordset
rsTemp.Filter = strFilter
Set rsTemp = rsTemp.OpenRecordset
If rsTemp.RecordCount > 0 Then
Set mListbox.Recordset = rsTemp
' mListbox.Selected(0) = True
' mListbox.Value = mListbox.Column(0)
Else
MsgBox "No records match " & strFilter
End If
mTextBox.SelStart = Len(mTextBox.Text)
Exit Sub
errLable:
If Err.Number = 3061 Then
MsgBox "Will not Filter. Verify Field Name is Correct."
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Private Sub unFilterList()
On Error GoTo errLable
Set mListbox.Recordset = mRsOriginalList
Exit Sub
errLable:
If Err.Number = 3061 Then
MsgBox "Will not Filter. Verify Field Name is Correct."
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Private Function getFilter(theText As String) As String
'To make this work well convert all field in the listbox to string
'Example: strDateDue: cstr(dtmDueDate)
Dim strFilter As String
Dim strLike As String
theText = Replace(theText, "'", "''")
If mFilterFromStart Then
strLike = " like '"
Else
strLike = " like '*"
End If
strFilter = Me.FieldToSearch & strLike & theText & "*'"
getFilter = strFilter
End Function
Private Sub AddItemToList()
Dim currentIndex As Long
currentIndex = Me.ListBox.ListIndex
If Me.ListBox.Selected(currentIndex) Then
Me.UniqueItems.Add (Me.ListBox.Column(Me.ColumnToSearch, currentIndex))
Else
Me.UniqueItems.Delete (Me.ListBox.Column(Me.ColumnToSearch, currentIndex))
End If
End Sub
Private Sub UnselectItems()
Dim varItm As Variant
For Each varItm In Me.ListBox.ItemsSelected
Me.ListBox.Selected(varItm) = False
Next varItm
End Sub
Private Sub ReselectItems()
Dim itemIndex As Integer
Dim selectionIndex As Integer
For itemIndex = 1 To Me.UniqueItems.count
For selectionIndex = 0 To Me.ListBox.ListCount - 1
If Me.ListBox.Column(Me.ColumnToSearch, selectionIndex) = Me.UniqueItems.Item(itemIndex) Then
Me.ListBox.Selected(selectionIndex) = True
End If
Next selectionIndex
Next itemIndex
End Sub
'************** Public Methods
Public Sub SortList(SortString As String)
Dim rs As DAO.Recordset
Set rs = mListbox.Recordset
rs.Sort = SortString
Set mListbox.Recordset = rs.OpenRecordset
Set rs = mRsOriginalList
rs.Sort = SortString
Set mRsOriginalList = rs.OpenRecordset
End Sub
'********************* Captured Events
Private Sub mTextBox_Change()
Call UnselectItems
Call FilterList
Call ReselectItems
End Sub
Private Sub mListBox_AfterUpdate()
Call AddItemToList
End Sub
Private Sub mForm_Current()
Call unFilterList
End Sub
Private Sub Class_Terminate()
Set mForm = Nothing
Set mListbox = Nothing
Set mRsOriginalList = Nothing
End Sub
Because of the need to store the selection to allow filtering/unfiltering needed another class to store the selections.
Class must be called: UniqueStringCollection
Code:
Option Compare Database
'Class UniqueStringCollection
Private mItemsSelected As New Collection
Public Property Get MyItemsSelected() As Collection
Set MyItemsSelected = mItemsSelected
End Property
Public Property Get count() As Long
count = mItemsSelected.count
End Property
Public Function Add(Item As String) As String
On Error GoTo errlbl
Dim i As Integer
Dim blnAdded As Boolean
mItemsSelected.Add Item, Item
blnAdded = True
Add = Item
Exit Function
errlbl:
'Throw an error if adding the same item
If Err.Number = 457 Then
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
End If
End Function
Public Function Item(index As Variant) As String
Item = mItemsSelected.Item(index)
End Function
Public Sub Delete(index As Variant)
mItemsSelected.Remove index
End Sub
Public Function GetIndexByName(ItemName As String) As Integer
Dim i As Integer
GetIndexByName = -1
For i = 1 To mItemsSelected.count
If mItemsSelected.Item(i) = ItemName Then
GetIndexByName = i
End If
Next i
End Function
Public Function ToString() As String
Dim i As Integer
For i = 1 To mItemsSelected.count
ToString = ToString & vbCrLf & mItemsSelected.Item(i)
Next i
End Function
