Form hanging while running listbox query

Question

My form is hanging for several seconds every time the user goes to a new record. The recordset for a listbox on the form is a query. The form is hanging until that query finishes and the listbox is populated.

My users need to be able to scroll through the records quickly. Currently, the user must wait for the listbox query to finish before moving to the next record. How can I stop the form from hanging?

Is there a way for DoEvents to be used to solve this problem?

Below is my code. I suspect that seeing all this code is not necessary, but I am sharing it all just in case.

I am using Access.

Thanks!

Option Compare Database   'Use database order for string comparisons
Option Explicit
Dim QuoteLogForm As Form
Public KeystrokeCount As Integer

'Define the similarity threshold for the matches list
Const SIMIL_THRESHOLD As Single = 0.83
Private m_strDialogResult As String

'The basis of this code was derived from http://www.accessmvp.com/tomvanstiphout/simil.htm

Private Sub Form_Current()    
    Matches
End Sub

Private Sub Matches()
      'This sub calls the functions necessary to generate a query that lists
      'the KFC RFQ #'s whose similarity exceeds the threashold, as defined above.

      Dim sql As String
      Dim strOpenArgs As String
      Dim strInClause As String

      'OpenArgs contains the part # to find similars for.
      strOpenArgs = Replace(Replace(Nz(Me.Part_Number_Textbox.Value), "-", ""), " ", "")                'Nz changes Nulls to blanks

      'Call the GetSimilarPartNos function below.
      'This function returns a string of KFC RFQ #'s that exceed the threashold, wrapped in single quotes and separated by commas.
      strInClause = GetSimilarPartNos(strOpenArgs)

      'If any similar part numbers were found, run a query to select all the listed records
      If VBA.Len(strInClause) > 0 Then
            'Select records whose KFC RFQ #'s are found in the strInClause list, sort from most to least similar
           sql = "select * from [Matches List Query] where [KFC RFQ #] in (" & strInClause & ")"    ' order by SimilPct desc, DateShort desc"

           '[Forms]![Price Form Parent]![Price Form].[Form].Customer_Filter_Box
          Set Me.[Matches List Form].Form.Recordset = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)
      Else
            'If no similar KFC RFQ #'s were found, select no records
          sql = "select * from [Matches List Query] where 1 = 0"
          Set Me.[Matches List Form].Form.Recordset = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)
      End If

End Sub

 Private Function GetSimilarPartNos(ByVal strPartNo As String) As String
 'The GetSimilarPartNos function calls the fnSimil function and compiles a list (strInClause)
 'of KFC RFQ #'s whose part numbers exceed the threashold
      Dim rs          As DAO.Recordset
      Dim strInClause As String
      Dim sngSimil    As Single

      'Erase all previous values in the [Quote Log].Simil field
      CurrentDb.Execute "update [Quote Log] set Simil = 0", dbFailOnError

      Set rs = CurrentDb.OpenRecordset("Quote Log")      ', dbOpenTable)

      'Loop to calculate the similarity of all part numbers
      While Not rs.EOF                  'Loop until the end
          Dim curPartNo As String
          curPartNo = Replace(Replace(Nz(rs![Part #]), "-", ""), " ", "")
            If rs![KFC RFQ #] = Me.[KFC RFQ #] Then
                GoTo 120
            End If
          sngSimil = fnSimil(curPartNo, strPartNo)

            'If the part number similarity value of a single record is greater than the 
            'threashold (as defined above), add the record's KFC RFQ # to strInClause
            'strInClause forms a list of KFC RFQ #'s whose part numbers exceed the threashold
            'in similarity, wrapped in single quotes and separated by commas
          If sngSimil >= SIMIL_THRESHOLD Then
              strInClause = strInClause & "'" & rs![KFC RFQ #] & "',"
              'Show the Simil value on this form
              rs.Edit
              rs!Simil = sngSimil
              rs.Update
          End If
 120    rs.MoveNext
      Wend
      rs.Close
      Set rs = Nothing

      'Once the strInClause is completed, remove the last comma from the list
      If Len(strInClause) > 0 Then strInClause = VBA.Left$(strInClause, Len(strInClause) - 1)
      GetSimilarPartNos = strInClause
End Function

Answer 1

I think you might possibly have the wrong form event. The form_Current event fires between each record and I can't imagine that's what you really need. Try moving your "Matches" routine into the OnLoad event instead.

Answer 2

The UI is hanging because the work is being done by the UI thread. If you want (or need) a more responsive application, you need to offload the work to a background thread. As far as I know, for VBA, that is not something for the feint of heart, but you can take a look, VBA + Threads in MS Access.

As access is a database, it suffers from all the drawbacks of any database, mainly finding data stored on slow, usually spinning, media. I suggest you take a look at this article: Create and use an index to improve performance to help you create efficient indexes for your queries, if you have not indexed for them already. You also need to consider the performance implications of WHERE, JOIN, and ORDER BY clauses in your queries. Make sure your indexes are optimized for your queries and your data is stored in a logical fashion for the way it will be queries out. Beyond that, if the database does not reside on the machine from which the queries are being executed, you have network I/O latency on top of expected Disk I/O latency. This can significantly impact the read performance of the database.