Option Compare Database
Option Explicit
'Class Module Name: FindAsYouTypeCombo
'Purpose: Turn any combobox into a "Find As You Type" 'Combobox
'Created by: MajP
'Demonstrates: OOP, and With Events
'
'Use: To use the class, you need a reference to DAO and code
'similar to the following in a form's module.
'Parmaters:
' TheComboBox: Your Combobox object passed as an object
' FilterFieldName: The name of the field to Filter as
' string
' FilterFromStart: Determines if you filter a field that
' starts with the text or if the text appears anywhere in
' the record.
'
'*******START: Place Code like this in the Form *******************
'
' Option Compare Database
' Option Explicit
' Public faytProducts As New FindAsYouTypeCombo
'
' Form_Open(Cancel As Integer)
' faytProducts.InitalizeFilterCombo Me.cmbProducts, "ProductName", False
' End Sub
'
'******* END: Form Code ******************
Private WithEvents mCombo As Access.ComboBox
Private WithEvents mForm As Access.Form
Private mFilterFieldName As String
Private mRsOriginalList As DAO.Recordset
Private mFilterFromStart As Boolean
Private mHandleArrows As Boolean
Private mAutoCompleteEnabled As Boolean
'---------------------------------------- Properties --------------------------
Public Property Get FilterComboBox() As Access.ComboBox
Set FilterComboBox = mCombo
End Property
Public Property Set FilterComboBox(TheComboBox As Access.ComboBox)
Set mCombo = TheComboBox
End Property
Private Sub mCombo_Change()
Call FilterList
End Sub
Public Property Get FilterFieldName() As String
FilterFieldName = mFilterFieldName
End Property
Public Property Let FilterFieldName(ByVal theFieldName As String)
mFilterFieldName = theFieldName
End Property
Public Property Get HandleArrows() As Boolean
HandleArrows = mHandleArrows
End Property
Public Property Let HandleArrows(ByVal TheValue As Boolean)
mHandleArrows = TheValue
End Property
'------------------------------------------- Handled Events ----------------
Private Sub mCombo_GotFocus()
'If mAutoCompleteEnabled = True Then mCombo.Dropdown
End Sub
Private Sub mCombo_AfterUpdate()
If Not mAutoCompleteEnabled Then Call unFilterList
End Sub
Private Sub mForm_Current()
Call unFilterList
End Sub
Private Sub mForm_Close()
' Code provided by BenSacheri to keep Access from crashing
Call Class_Terminate
End Sub
Private Sub mCombo_KeyDown(KeyCode As Integer, Shift As Integer)
' Handle keys that affect the auto-complete feel of the combobox. BS 10/13/2015
If mHandleArrows = True Then
Select Case KeyCode
Case vbKeyDown, vbKeyUp, vbKeyReturn, vbKeyPageDown, vbKeyPageUp
' When these special keys are hit they begin to select records
' from the dropdown list. Without this, as soon as one record
' is selected (by highlighting it) then the entire filter is
' set to that item making it impossible to use the keyboard to
' scroll down and pick an item down in the list.
mAutoCompleteEnabled = False
Case Else
mAutoCompleteEnabled = True
End Select
End If
End Sub
'---------------------------------- Procedures ----------------------------
Public Sub InitalizeFilterCombo(TheComboBox As Access.ComboBox, FilterFieldName As String, Optional FilterFromStart As Boolean = True, Optional HandleArrows As Boolean = True)
On Error GoTo errLabel
Dim rs As DAO.Recordset
If Not TheComboBox.RowSourceType = "Table/Query" Then
MsgBox "This class will only work with a combobox that uses a Table or Query as the Rowsource"
Exit Sub
End If
Set mCombo = TheComboBox
Set mForm = TheComboBox.Parent
mHandleArrows = HandleArrows
mAutoCompleteEnabled = True
If mHandleArrows = True Then
mCombo.OnKeyDown = "[Event Procedure]"
mCombo.OnClick = "[Event Procedure]"
End If
mFilterFieldName = FilterFieldName
mFilterFromStart = FilterFromStart
mForm.OnCurrent = "[Event Procedure]"
mCombo.OnGotFocus = "[Event Procedure]"
mCombo.OnChange = "[Event Procedure]"
mCombo.AfterUpdate = "[Event Procedure]"
mForm.OnClose = "[Event Procedure]"
With mCombo
.SetFocus
.AutoExpand = False
End With
If mCombo.Recordset Is Nothing Then
Set rs = CurrentDb.OpenRecordset(TheComboBox.RowSource)
Set mCombo.Recordset = rs
End If
Set mRsOriginalList = mCombo.Recordset.Clone
Exit Sub
errLabel:
MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub FilterList()
On Error GoTo errLable
Dim rsTemp As DAO.Recordset
Dim strText As String
Dim strFilter As String
strText = mCombo.Text
If mFilterFieldName = "" Then
MsgBox "Must Supply A FieldName Property to filter list."
Exit Sub
End If
If mAutoCompleteEnabled = False Then Exit Sub
If mFilterFromStart = True Then
strFilter = mFilterFieldName & " like '" & strText & "*'"
Else
strFilter = mFilterFieldName & " like '*" & strText & "*'"
End If
Set rsTemp = mRsOriginalList.OpenRecordset
rsTemp.Filter = strFilter
Set rsTemp = rsTemp.OpenRecordset
If rsTemp.RecordCount > 0 Then
Set mCombo.Recordset = rsTemp
End If
mCombo.Dropdown
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 mCombo.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 Sub Class_Terminate()
Set mForm = Nothing
Set mCombo = Nothing
Set mRsOriginalList = Nothing
End Sub
