Option Explicit
'Class Module Name: FindAsYouTypeForm
'Purpose: Turn any Form into a "Find As You Type" Form
'Created by: MajP
Private WithEvents mForm As Access.Form
Private WithEvents mSearchForm As Access.Form
Private WithEvents mTextBox As Access.TextBox
Private mFormFilterType As Long
Private mFieldToSearch As String
Public Enum FormFilterType
ffrm_AnywhereInString = 0
ffrm_FromBeginning = 1
End Enum
Private Sub mTextBox_Change()
Call FilterForm
End Sub
Private Sub FilterForm()
On Error GoTo errLabel
Dim strFilter As String
mTextBox.SetFocus
If Not Trim(mTextBox.Text & " ") = "" Then
'MsgBox getFilter(mTextBox.Text)
mForm.Filter = getFilter(mTextBox.Text)
mForm.FilterOn = True
If mForm.Recordset.RecordCount = 0 Then
MsgBox "No items matched filter " & vbCrLf & mForm.Filter, vbInformation, "No Items Found"
mForm.FilterOn = False 'needed to set focus on textbox
DoEvents
mTextBox.SetFocus
mTextBox.Value = Left(mTextBox.Text, Len(mTextBox.Text) - 1)
FilterForm
End If
Else
'Call unFilterForm
End If
mTextBox.SetFocus
mTextBox.SelStart = Len(mTextBox.Text)
Exit Sub
errLabel:
If Err.Number = 3061 Then
MsgBox "Will not Filter. Verify Field Name is Correct."
ElseIf Err.Number = 2185 Then
MsgBox "No item found.", vbInformation, "No Item Found."
unFilterForm
Exit Sub
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Private Sub unFilterForm()
On Error GoTo errLabel
mTextBox.SetFocus
mForm.Filter = ""
mForm.FilterOn = False
mTextBox.Value = ""
mTextBox.SetFocus
Exit Sub
errLabel:
MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub Class_Terminate()
Set mForm = Nothing
End Sub
Public Sub Initialize(TheForm As Access.Form, TheTextBox As Access.TextBox, Optional FieldToSearch As String = "", Optional FilterType As FormFilterType = anywhereinstring)
On Error GoTo errLabel
Set mTextBox = TheTextBox
Set mForm = TheForm
mFieldToSearch = FieldToSearch
Me.FilterType = FilterType
mForm.OnCurrent = "[Event Procedure]"
mTextBox.OnGotFocus = "[Event Procedure]"
mTextBox.OnChange = "[Event Procedure]"
Exit Sub
errLabel:
MsgBox Err.Number & " " & Err.Description
End Sub
Private Function getFilter(ByVal 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
Dim rs As DAO.Recordset
Dim fld As DAO.Field
TheText = Replace(TheText, "'", "''")
If Me.FilterType = ffrm_FromBeginning Then
strLike = " like '"
Else
strLike = " like '*"
End If
Set rs = mForm.Recordset
If mFieldToSearch = "" Then
For Each fld In rs.Fields
If fld.Type = dbMemo Or fld.Type = dbText Then
If strFilter = "" Then
strFilter = fld.Name & strLike & TheText & "*'"
Else
strFilter = strFilter & " OR " & fld.Name & strLike & TheText & "*'"
End If
End If
Next fld
Else
strFilter = mFieldToSearch & strLike & TheText & "*'"
End If
getFilter = strFilter
End Function
Public Property Get FilterType() As FormFilterType
FilterType = mFormFilterType
End Property
Public Property Let FilterType(ByVal TheFilterType As FormFilterType)
mFormFilterType = TheFilterType
End Property
Public Property Get FieldToSearch() As String
FieldToSearch = mFieldToSearch
End Property
Public Property Let FieldToSearch(ByVal theFieldToSearch As String)
mFieldToSearch = theFieldToSearch
End Property
Public Sub SearchAllFields()
mFieldToSearch = ""
End Sub