I've inherited a database that has a search form. Basically the user can type in a file number or a streetname or an owner name and it searches these 3 fields simultaneously for any matches. As the program finds matches it puts the matching records in a text box below the search field. The user can then double-click the record they want and it opens another form which contains all the info. The search works but it is incredibly SLOW even when there are a small number of records in the table (< 100). Any help would be appreciated !!
Code:
Option Compare Database
Option Explicit
Private Sub Form_Open(Cancel As Integer)
Me.lstFound.RowSource = ""
End Sub
Private Sub lstFound_DblClick(Cancel As Integer)
Dim strAM_FileCode As String
strAM_FileCode = Trim(Mid(Me.lstFound.Value, 13, FindFirst(Me.lstFound.Value, " ")))
DoCmd.OpenForm "Add_View_OPA", acNormal
Forms!Add_View_OPA.Recordset.FindFirst "AM_File = '" & strAM_FileCode & "'"
End Sub
Private Sub txtSearch_Change()
Me.lstFound.RowSource = ""
If Len(Me.txtSearch.Text) > 5 Then
Dim con As ADODB.Connection
Set con = CurrentProject.Connection
Dim rs As New ADODB.Recordset
rs.ActiveConnection = con
Dim newListItem As String
'Create SQL Selection
Dim sql As String
' -- Search the Area Municipal FileCode
sql = "SELECT TOP 100 Amendments.AM_File, Amendments.Owner, Amendments.Address_StName, Amendments.Full_Address , Amendments.Date_Received " & _
"FROM Amendments " & _
"WHERE Amendments.AM_File Like '%" & Me.txtSearch.Text & "%'" & _
"ORDER BY Amendments.Date_Received"
rs.Open sql
While rs.BOF <> True And rs.EOF <> True
'newListItem = Replace(Replace(CStr(rs.Fields("ThirtyT").Value) & " " & CStr(rs.Fields("Mun").Value) & " " & CStr(rs.Fields("Location").Value) & " " & CStr(rs.Fields("Owner").Value), ",", " "), Me.txtSearch.Text, UCase(Me.txtSearch.Text))
newListItem = "AM_File# -- " & Nz(rs.Fields("AM_File").Value, " ") & " " & " Owner -- " & Nz(rs.Fields("Owner").Value, " ") & " " & " Address -- " & Nz(rs.Fields("Full_Address").Value, " ")
newListItem = Replace(newListItem, ",", " ")
newListItem = Replace(newListItem, Me.txtSearch.Text, UCase(Me.txtSearch.Text))
NoDuplicatesInList Me.lstFound, newListItem
rs.MoveNext
Wend
rs.Close
' -- Search the St_Name field
sql = "SELECT TOP 100 Amendments.AM_File, Amendments.Owner, Amendments.Address_StName, Amendments.Full_Address, Amendments.Date_Received " & _
"FROM Amendments " & _
"WHERE Amendments.Address_StName Like '%" & Me.txtSearch.Text & "%'" & _
"ORDER BY Amendments.Date_Received"
rs.Open sql
While rs.BOF <> True And rs.EOF <> True
newListItem = "AM_File# -- " & Nz(rs.Fields("AM_File").Value, " ") & " " & " " & " Owner -- " & Nz(rs.Fields("Owner").Value, " ") & " " & " Address -- " & Nz(rs.Fields("Full_Address").Value, " ")
newListItem = Replace(newListItem, ",", " ")
newListItem = Replace(newListItem, Me.txtSearch.Text, UCase(Me.txtSearch.Text))
NoDuplicatesInList Me.lstFound, newListItem
rs.MoveNext
Wend
rs.Close
' -- Search the Owner field
sql = "SELECT TOP 100 Amendments.AM_File, Amendments.Owner, Amendments.Address_StName, Amendments.Full_Address, Amendments.Date_Received " & _
"FROM Amendments " & _
"WHERE Amendments.Owner Like '%" & Me.txtSearch.Text & "%' " & _
"ORDER BY Amendments.Date_Received"
rs.Open sql
While rs.BOF <> True And rs.EOF <> True
newListItem = "AM_File# -- " & Nz(rs.Fields("AM_File").Value, " ") & " " & " " & " Owner -- " & Nz(rs.Fields("Owner").Value, " ") & " " & " Address -- " & Nz(rs.Fields("Full_Address").Value, " ")
newListItem = Replace(newListItem, ",", " ")
newListItem = Replace(newListItem, Me.txtSearch.Text, UCase(Me.txtSearch.Text))
NoDuplicatesInList Me.lstFound, newListItem
rs.MoveNext
Wend
rs.Close
'Close off Recordset
Set rs = Nothing
Set con = Nothing
End If
End Sub
Private Sub NoDuplicatesInList(lst As ListBox, str As String)
Dim tf As Boolean
Dim x As Integer
If lst.ListCount = 0 And str <> "" Then
lst.AddItem str
'check to make sure no duplicate entries get into list box
Else
tf = False
For x = 0 To lst.ListCount - 1
If lst.ItemData(x) <> str Then
tf = False
Else
tf = True
Exit For
End If
Next x
If tf = False And str <> "" Then
lst.AddItem str
End If
End If
End Sub
Private Function FindFirst(str As String, chr As String) As Integer
Dim i As Integer
i = 1
Do While i < Len(str)
If Mid(str, i, 1) = chr Then
FindFirst = i
Exit Do
End If
i = i + 1
Loop
End Function
Last edited by a moderator: