Select while typing in list box MS Access 2003 4

[puforee]

I have a list box. When I type a letter it goes to that letter in the list. If I type another letter it goes to that letter as the first character in the list box. Example.

1 Type the letter J and it shows Jim, John, James, Jonas etc.
2 Then type the additional letter O and it shows Oran, Orion, Orange etc.

I want to type J and show what is above in # 1 then I want to type O and show John and Jonas. Continue typing with an h and it should show John.

How do I set this up?

Thanks,

 

[MajP]

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.

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

'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

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