Some years ago MajP was kind enough to let me use a very nice filter in a database I was putting together. I've since adapted this database to serve a hobby of mine and have added a couple of new search parameters. However, I cannot get one of these to work. The field in question is a date (dd/mm/yy) format. I'm sure that the issue I have is with the format (i.e. date), as all the other search features work OK. However, when I select a date from the drop down list, I get a "No records found" error. Here is the code for the filter form:
Here is the Module:
Any help is greatly appreciated.
Code:
'form filter code by MajP from Tek-Tips ([URL unfurl="true"]http://www.tek-tips.com)[/URL]
Option Compare Database
Public fslTools As FilterSortListBox
Public blnSelect As Boolean
'sorts search results based upon the column heading
Private Sub cmdDate_Click()
fslTools.SortList ("Date, SourceID")
End Sub
Private Sub cmdFilter_Click()
Me.Visible = False
End Sub
Private Sub cmdDesc_Click()
fslTools.SortList ("Description, YearID")
End Sub
Private Sub cmdID_Click()
fslTools.SortList ("ToolID")
End Sub
Private Sub cmdLocation_Click()
fslTools.SortList ("LocationID, YearID")
End Sub
Private Sub cmdMan_Click()
fslTools.SortList ("ManufacturerID, YearID")
End Sub
Private Sub cmdSelect_Click()
blnSelect = True
Me.Visible = False
End Sub
Private Sub cmdSource_Click()
fslTools.SortList ("SourceID, SubCategoryID,YearID")
End Sub
Private Sub cmdYear_Click()
fslTools.SortList ("YearID")
End Sub
Private Sub cmdCategory_Click()
fslTools.SortList ("CategoryID, SubCategoryID,YearID")
End Sub
Private Sub cmdSubCategory_Click()
fslTools.SortList ("SubCategoryID, YearID")
End Sub
Private Sub Form_Activate()
DoCmd.Maximize
End Sub
Private Sub Form_Close()
resetValues
End Sub
Public Sub resetValues()
On Error GoTo errlbl
Me.qMan1.Value = ""
Me.qCat1.Value = ""
Me.qSub1.Value = ""
Me.qLoc1.Value = ""
Me.qSrc1.Value = ""
Me.qYear1.Value = ""
Me.qDate1.Value = ""
Exit Sub
errlbl:
If Err.Number = 2467 Then
Exit Sub
Else
MsgBox Err.Number & Err.Description
End If
End Sub
Private Sub Form_GotFocus()
DoCmd.Maximize
End Sub
Private Sub Form_Load()
Set fslTools = New FilterSortListBox
fslTools.Initialize Me.lstSearch
resetValues
End Sub
Private Sub qDate1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qMan1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qYear1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qCat1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qLoc1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qSrc1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub qSub1_AfterUpdate()
fslTools.FilterList (getFilter)
End Sub
Private Sub Reset_Click()
resetValues
fslTools.unFilterList
End Sub
Private Sub Search_Click()
Me.Visible = False
End Sub
Private Sub ExitForm_Click()
On Error GoTo Err_ExitForm_Click
DoCmd.Close acForm, Me.Name
Exit_ExitForm_Click:
Exit Sub
Err_ExitForm_Click:
MsgBox Err.Description
Resume Exit_ExitForm_Click
End Sub
Public Function getFilter() As String
' On Error GoTo errLable
Dim strType As String
Dim strManufacturer As String
Dim strSerial As String
Dim strSet As String
Dim strSubCategory As String
Dim strLocation As String
Dim strSource As String
Dim strYear As String
Dim strDate As Date
Dim andOR As String
Dim removeEnd As Integer
If Not blnSelect Then
If Me.framAndOr.Value = 0 Then
andOR = " OR "
removeEnd = 4
Else
andOR = " AND "
removeEnd = 5
End If
If Not Trim(Me.qMan1 & " ") = "" Then
strManufacturer = "[ManufacturerID] = '" & qMan1 & "'" & andOR
End If
If Not Trim(Me.qCat1 & " ") = "" Then
strType = "[CategoryID] = '" & qCat1 & "'" & andOR
End If
If Not Trim(Me.qSub1 & " ") = "" Then
strType = "[SubCategoryID] = '" & qSub1 & "'" & andOR
End If
If Not Trim(Me.qLoc1 & " ") = "" Then
strLocation = "[LocationID] = '" & qLoc1 & "'" & andOR
End If
If Not Trim(Me.qSrc1 & " ") = "" Then
strSource = "[SourceID] = '" & qSrc1 & "'" & andOR
End If
If Not Trim(Me.qYear1 & " ") = "" Then
strYear = "[YearID] = '" & qYear1 & "'" & andOR
End If
If Not Trim(Me.qDate1 & " ") = "" Then
strYear = "[Date] = #" & Format(Me.[qDate1].Value, "dd\/mm\/yy") & "#" & andOR
End If
getFilter = strType + strManufacturer + strLocation + strSubCategory + strSource + strYear
getFilter = Left(getFilter, Len(getFilter) - removeEnd)
Else
If Not IsNull(lstSearch) Then
getFilter = "[ToolID] = " & Me.lstSearch
End If
End If
Debug.Print getFilter
'You may comment this out
'Debug.Print "Filter Criteria: " & getFilter
'Exit Function
'errLable:
'MsgBox Err.Number & " " & Err.Description
End FunctionHere is the Module:
Code:
Option Compare Database
Option Explicit
'Class Module Name: FindAsYouListBox
'Purpose: Turn any Listbox into a "Find As You Type" listbox
'Created by: MajP
Private WithEvents mListbox As Access.ListBox
Private WithEvents mForm As Access.Form
Private mFilterString As String
Private mSortString As String
Private mRsOriginalList As DAO.Recordset
Private Sub mListBox_AfterUpdate()
'Call unFilterList
End Sub
Private Sub mForm_Current()
Call unFilterList
End Sub
Public Sub FilterList(FilterString As String)
On Error GoTo errLable
Dim rsTemp As DAO.Recordset
Set rsTemp = mRsOriginalList.OpenRecordset
rsTemp.Filter = FilterString
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 Found"
Call unFilterList
End If
Exit Sub
errLable:
If Err.Number = 3061 Then
MsgBox "Will not Filter. Verify filter string is Correct."
Else
MsgBox Err.Number & " " & Err.Description
End If
End Sub
Public 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 Sub Class_Terminate()
Set mForm = Nothing
Set mListbox = Nothing
Set mRsOriginalList = Nothing
End Sub
Public Sub Initialize(theListBox As Access.ListBox)
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
mForm.OnCurrent = "[Event Procedure]"
mListbox.AfterUpdate = "[Event Procedure]"
Set mRsOriginalList = mListbox.Recordset.Clone
Exit Sub
errLabel:
MsgBox Err.Number & " " & Err.Description
End Sub
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 SubAny help is greatly appreciated.
