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
'
'To Use: Place this code in a Class Module
' The class MUST be called "FindAsYouTypeCombo"
'
'*******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, True, False
' End Sub
'
'******* END: Form Code ******************
'
'
'Parameters of the InitializeFilterCombo:
' TheComboBox: Your Combobox object passed as an object reference
' FilterFieldName: The name of the field to Filter passed as a string variable
' SearchType: Determines if you filter a field that
' starts with the desired text or if the text appears anywhere in the record
' HandleArrows: This controls the behavior to move up and down the list with arrow keys
' and not select the first value. Boolean variable
' HandleInternationalCharacters: This allows you to search for international characters. (a = á,N = Ñ, etc.)
' This may slow down the procedure because it does a lot of replacements. Boolean
'
Private WithEvents mCombo As Access.ComboBox
Private WithEvents mForm As Access.Form
Private mFilterFieldName As String
Private mRsOriginalList As DAO.Recordset
Private mSearchType As SearchType
Private mHandleArrows As Boolean
Private mAutoCompleteEnabled As Boolean
Private mHandleInternationalCharacters As Boolean
Private mRowSource As String
Public Enum SearchType
AnywhereInString = 0
FromBeginning = 1
End Enum
'---------------------------------------- Properties --------------------------
'Only Needed for reassigning a new reocordsource. Not related to FAYT. Still required to have a recordsource initially
Public Property Get RdSource() As String
RowSource = mRowSource
End Property
Public Property Let RowSource(ByVal NewRowSource As String)
Dim rs As DAO.Recordset
mRowSource = NewRowSource
'If mCombo.Recordset Is Nothing Then
Set rs = CurrentDb.OpenRecordset(NewRowSource)
Set mCombo.Recordset = rs
'End If
Set mRsOriginalList = mCombo.Recordset.Clone
End Property
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
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_Change()
Call FilterList
mAutoCompleteEnabled = True
' mCombo.Dropdown
End Sub
Private Sub mCombo_AfterUpdate()
mAutoCompleteEnabled = True
unFilterList
'MsgBox "After" & mAutoCompleteEnabled
End Sub
Private Sub mForm_Current()
Call unFilterList
End Sub
Private Sub mForm_Close()
Call Class_Terminate
End Sub
Private Sub mCombo_Click()
mAutoCompleteEnabled = False
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
'---------------------------------- Class Procedures ----------------------------
Public Sub InitalizeFilterCombo(TheComboBox As Access.ComboBox, FilterFieldName As String, _
Optional TheSearchType As SearchType = SearchType.AnywhereInString, _
Optional HandleArrows As Boolean = True, _
Optional HandleInternationalCharacters 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
mHandleInternationalCharacters = HandleInternationalCharacters
'HandleArrows allows you to use the arrow keys to move up and down without selecting the value
mCombo.OnClick = "[Event Procedure]"
If mHandleArrows = True Then
mCombo.OnKeyDown = "[Event Procedure]"
mCombo.OnClick = "[Event Procedure]"
End If
mFilterFieldName = FilterFieldName
mSearchType = TheSearchType
mForm.OnCurrent = "[Event Procedure]"
mForm.OnClose = "[Event Procedure]"
mCombo.OnGotFocus = "[Event Procedure]"
mCombo.OnChange = "[Event Procedure]"
mCombo.OnClick = "[Event Procedure]"
mCombo.AfterUpdate = "[Event Procedure]"
mForm.OnClose = "[Event Procedure]"
With mCombo
.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
strText = Replace(strText, "'", "''")
strText = Replace(strText, "#", "[#]")
If mHandleInternationalCharacters Then
strText = InternationalCharacters(strText)
End If
If mFilterFieldName = "" Then
MsgBox "Must Supply A FieldName Property to filter list."
Exit Sub
End If
'Debug.Print mAutoCompleteEnabled
If mAutoCompleteEnabled = False Then Exit Sub
If mSearchType = SearchType.FromBeginning Then
strFilter = mFilterFieldName & " like '" & strText & "*'"
Else
strFilter = mFilterFieldName & " like '*" & strText & "*'"
End If
Set rsTemp = mRsOriginalList.OpenRecordset
rsTemp.Filter = strFilter
Set rsTemp = rsTemp.OpenRecordset
If Not (rsTemp.EOF And rsTemp.BOF) Then
rsTemp.MoveLast
rsTemp.MoveFirst
'Debug.Print rsTemp.RecordCount & " Count " & strFilter
Else
beep
mAutoCompleteEnabled = True
End If
Set mCombo.Recordset = rsTemp
If rsTemp.RecordCount > 0 Then
mCombo.Dropdown
End If
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
'------------------------------------ To Handle International Characters ---------------------------
Private Function InternationalCharacters(ByVal strText As String) As String
InternationalCharacters = strText
'If you type international turn first to english
'Type international and get english
InternationalCharacters = Replace(InternationalCharacters, "á", "a")
InternationalCharacters = Replace(InternationalCharacters, "é", "e")
InternationalCharacters = Replace(InternationalCharacters, "í", "i")
InternationalCharacters = Replace(InternationalCharacters, "ó", "o")
InternationalCharacters = Replace(InternationalCharacters, "ú", "u")
InternationalCharacters = Replace(InternationalCharacters, "ü", "u")
InternationalCharacters = Replace(InternationalCharacters, "ñ", "n")
'Add others as necessary á, é, í, ó, ú, ü, ñ
'Type english and get international
InternationalCharacters = Replace(InternationalCharacters, "A", "[AÁÀÂÄaá]")
InternationalCharacters = Replace(InternationalCharacters, "E", "[EÉÈÊËeé]")
InternationalCharacters = Replace(InternationalCharacters, "I", "[IÍÌÎÏií]")
InternationalCharacters = Replace(InternationalCharacters, "O", "[OÓÒÔÖ0oóøØ]")
InternationalCharacters = Replace(InternationalCharacters, "U", "[UÚÙÛÜuú]")
InternationalCharacters = Replace(InternationalCharacters, "N", "[NnñÑ]")
InternationalCharacters = Replace(InternationalCharacters, "C", "[CcçÇ]")
End Function
'-----------------------------------------End --------------------------------------------
Private Sub Class_Terminate()
Set mForm = Nothing
Set mCombo = Nothing
Set mRsOriginalList = Nothing
End Sub
