Option Compare Database
Option Explicit

Const constTIMEOUT = 300     ' search timeout in milliseconds [300]
Const constAUTOSELECT = 1    ' 0: none; 1: pre-select; 2:full auto
Const constMINLENGHT = 2     ' minimum length of text in control for starting search


'Class for support search-as-you-type feture for comboboxes
' Author of idea: Markus G Fischer, Geneva, 2011-06
' Written for Experts-Exchange: http://e-e.com/A_6490.html
' Modified by Sergey Shingarev, Thailand, 2015-07
'
'Using: Start typing in combo, after MinLenght characters and if you stop more than TimeOut
' milliseconds, search started. Spaces in typed text replaced by "*" wildcard
' Tab-out behaviour depends on AutoSelect
'
'Using in form:
'
'In combobox:
'set Autoxpand=No
'
'in RowSource replace column for search by expression adding chr(9)
'at the begining for full disabling of system autosearch:
'ArticleProduct: Chr(9) & [Products].[ArticleProduct]
'
'and add
'Like '*' as criteria for search column. Make sure that quotes are single.
'
'Declare on module level of form
'Dim mcboProd As New clsComboSearch
'
'
'Private Sub Form_Load()
'    mcboProd.Init Me.cboId_Product
'End Sub
'
Public OnTheFly     As Boolean      ' True to search while typing [True]
Public TIMEOUT      As Integer      ' search timeout in milliseconds [300]
Public AutoSelect   As Byte         ' 0: none; 1: pre-select; 2:full auto
Public MinLenght    As Integer      ' minimum lenghth of text in control for strting search

' class-level variables, used in more than one method
Dim mvarCriteria    As Variant      ' global WHERE clause
Dim mfDirty         As Boolean      ' True if the row source was changed
Dim mvarLast        As Variant      ' currently active keyword criteria
Dim mstrSelect      As String       ' original select from combo
Dim mstrOrderBy     As String

' event variables for the combo and for a timer form
Dim WithEvents mcboAny As ComboBox
Dim WithEvents mfrmClock As Form 'separate form for timer used because timer of current form may be already used.

Public Sub Init(Combo As ComboBox, Optional Criteria = "")
      ' Captures the combo's events and the optional WHERE clause;
      ' writes the initial row source of the combo.
          
          'catch necessary events
10       On Error GoTo ErrorHandler

20        Combo.OnChange = "[Event Procedure]"
30        Combo.OnEnter = "[Event Procedure]"
40        Combo.OnExit = "[Event Procedure]"
50        Combo.OnNotInList = "[Event Procedure]"
          
60        Set mcboAny = Combo
70        mvarCriteria = Criteria
80        mstrSelect = mcboAny.RowSource
90        mfDirty = True
          'ResetRowSource

ExitHere:
100      On Error GoTo 0
110      Exit Sub

ErrorHandler:
120   Select Case Err
      Case 0
130      Resume Next
140   Case Else
150      LogError Err.Number, Err.Description, Erl, "Init", "clsComboSearch"
160      Resume ExitHere
170   End Select



End Sub

Private Sub ResetRowSource(Optional Criteria)
10       On Error GoTo ErrorHandler

20        If IsMissing(Criteria) Then Criteria = mvarCriteria
30        If Nz(Criteria, "") <> "" Then
40            mcboAny.RowSource = Replace(mstrSelect, "Like '*'", "Like '*" & Criteria & "*'")
50        Else
60            mcboAny.RowSource = mstrSelect
70            If mcboAny.ListCount < 16 Then
80                mcboAny.ListRows = IIf(Nz(mcboAny.ListCount, 0) = 0, 1, mcboAny.ListCount)
90            Else
100               mcboAny.ListRows = 16
110           End If
              'toggle dropdown for refreshing
120           SendKeys "%{DOWN}"
130           SendKeys "%{DOWN}"
140           mcboAny.Dropdown
150       End If
160       mfDirty = True

ExitHere:
170      On Error GoTo 0
180      Exit Sub

ErrorHandler:
190   Select Case Err
      Case 0
200      Resume Next
210   Case Else
220      LogError Err.Number, Err.Description, Erl, "ResetRowSource", "clsComboSearch"
230      Resume ExitHere
240   End Select

End Sub

Private Sub PerformSearch()
          Static sfBusy   As Boolean      ' semaphore
          Dim varWhere    As Variant      ' criteria
          Dim strText As String
          Dim strWords()  As String       ' array of keywords
          Dim varW        As Variant      ' keyword loop variable
          
10       On Error GoTo ErrorHandler

          ' semaphore, prevents re-entrant execution
20        Do While sfBusy: DoEvents: Loop
30        sfBusy = True
          
          ' reset time-out for on the fly searching
40        If Me.OnTheFly Then mfrmClock.TimerInterval = 0
          
          ' do not interpret an actual selection from the list
50        If mcboAny.ListCount > 0 And mcboAny.ListIndex >= 0 Then GoTo ExitHere
          
60        strText = mcboAny.Text
70        If Len(Trim(strText)) > 0 Then
      '        varWhere = ""
      '        strWords = Split(strText)
      '        For Each varW In strWords
      '            If Len(varW) Then
      '                varWhere = varWhere + " And " & "Establishment Like '*" + Swiss(varW) + "*'"
      '        Next varW
80            varWhere = Replace(strText, " ", "*")
90        Else
100           varWhere = ""
110       End If
          
          ' if next keystroke already in line, skip to end
120       If Me.OnTheFly Then If mfrmClock.TimerInterval Then GoTo ExitHere
          
130       If Nz(varWhere) <> Nz(mvarLast) Then
              ' a new criteria was built: apply it to the row source
      'Debug.Print Now(), "PerformSearch, ResetRowSource " & varWhere
140           ResetRowSource varWhere
150           If mcboAny.ListCount Then Else
160           mfDirty = True
170           DoEvents
              'toggle dropdown for refreshing
180           SendKeys "%{DOWN}"
190           SendKeys "%{DOWN}"
200           mcboAny.Dropdown
210           mvarLast = varWhere
220       End If
          
ExitHere:
          ' release semaphore
230       sfBusy = False
240      On Error GoTo 0
250      Exit Sub

ErrorHandler:
          ' release semaphore
260       sfBusy = False
270   Select Case Err
      Case 0
280      Resume Next
290   Case Else
300      LogError Err.Number, Err.Description, Erl, "PerformSearch", "clsComboSearch"
310      Resume ExitHere
320   End Select


End Sub

Private Sub Class_Initialize()
      ' set default behaviour
10       On Error GoTo ErrorHandler

20        Me.OnTheFly = True
30        Me.TIMEOUT = constTIMEOUT
40        Me.AutoSelect = constAUTOSELECT
50        Me.MinLenght = constMINLENGHT

ExitHere:
60       On Error GoTo 0
70       Exit Sub

ErrorHandler:
80    Select Case Err
      Case 0
90       Resume Next
100   Case Else
110      LogError Err.Number, Err.Description, Erl, "Class_Initialize", "clsComboSearch"
120      Resume ExitHere
130   End Select

End Sub

Private Sub Class_Terminate()
      ' release variables (superfluous precaution in this case)
10       On Error GoTo ErrorHandler

20        Set mcboAny = Nothing
30        Set mfrmClock = Nothing

ExitHere:
40       On Error GoTo 0
50       Exit Sub

ErrorHandler:
60    Select Case Err
      Case 0
70       Resume Next
80    Case Else
90       LogError Err.Number, Err.Description, Erl, "Class_Terminate", "clsComboSearch"
100      Resume ExitHere
110   End Select

End Sub

Private Sub mcboAny_Change()
      ' on change, start the timer of an instanced timer form
      'Debug.Print Now(), "mcboAny_Change"
10       On Error GoTo ErrorHandler

20        If Me.OnTheFly Then
30            If mfrmClock Is Nothing Then Set mfrmClock = New Form_frmComboBoxTimer
40            mfrmClock.TimerInterval = Me.TIMEOUT
50        End If

ExitHere:
60       On Error GoTo 0
70       Exit Sub

ErrorHandler:
80    Select Case Err
      Case 0
90       Resume Next
100   Case Else
110      LogError Err.Number, Err.Description, Erl, "mcboAny_Change", "clsComboSearch"
120      Resume ExitHere
130   End Select

End Sub

Private Sub mcboAny_Enter()
      'Debug.Print Now(), "mcboAny_Enter"
      ' access the list count property: populates the combo completely
10       On Error GoTo ErrorHandler

20        If mcboAny.ListCount Then Else

ExitHere:
30       On Error GoTo 0
40       Exit Sub

ErrorHandler:
50    Select Case Err
      Case 0
60       Resume Next
70    Case Else
80       LogError Err.Number, Err.Description, Erl, "mcboAny_Enter", "clsComboSearch"
90       Resume ExitHere
100   End Select

End Sub

Private Sub mcboAny_Exit(Cancel As Integer)
      'Debug.Print Now(), "mcboAny_Exit"
      ' release timer and resets default row source
10       On Error GoTo ErrorHandler

20        Set mfrmClock = Nothing
30        If mfDirty Then
40            ResetRowSource
50            mfDirty = False
60        End If
70        mvarLast = Null

ExitHere:
80       On Error GoTo 0
90       Exit Sub

ErrorHandler:
100   Select Case Err
      Case 0
110      Resume Next
120   Case Else
130      LogError Err.Number, Err.Description, Erl, "mcboAny_Exit", "clsComboSearch"
140      Resume ExitHere
150   End Select

End Sub

Private Sub mcboAny_NotInList(NewData As String, Response As Integer)
      'Debug.Print Now(), "mcboAny_NotInList"
          
10       On Error GoTo ErrorHandler

20        If Me.OnTheFly Then
              ' pending change?
30            If mfrmClock.TimerInterval Then PerformSearch
40        Else
50            PerformSearch
60        End If
          
70        With mcboAny
          
80            If .ListCount = 0 Then
                  ' using the combo box as message box!
90                .RowSource = "SELECT Null, '*** no matching records ***'"
100               .Undo
110               Response = acDataErrContinue
120               mfDirty = True
              
130           ElseIf (.ColumnHeads And .ListCount = 2) Or (Not .ColumnHeads And .ListCount = 1) Or Me.AutoSelect = 2 Then
                  ' automatic selection from a one-item list
140               If .ColumnHeads Then
150                   .RowSource = "SELECT " & .ItemData(1) & ", '" & NewData & "'"
160               Else
170                   .RowSource = "SELECT " & .ItemData(0) & ", '" & NewData & "'"
180               End If
190               Response = acDataErrAdded
200               mfDirty = True
                  
210           ElseIf Me.AutoSelect = 1 Then
                  ' reopen combo box, but pre-select the first item
220               .Undo
230               If .ColumnHeads Then
240                   .Value = .ItemData(1)
250               Else
260                   .Value = .ItemData(0)
270               End If
280               Response = acDataErrContinue
                  
290           Else
                  ' reopen list to force selection
300               Response = acDataErrContinue
                  
310           End If
320       End With
330       mvarLast = "*"

ExitHere:
340      On Error GoTo 0
350      Exit Sub

ErrorHandler:
360   Select Case Err
      Case 0
370      Resume Next
380   Case Else
390      LogError Err.Number, Err.Description, Erl, "mcboAny_NotInList", "clsComboSearch"
400      Resume ExitHere
410   End Select

          
End Sub

Private Sub mfrmClock_Timer()
      ' The form was idle for at least Me.TimeOut milliseconds
10       On Error GoTo ErrorHandler

20        If Len(Nz(mcboAny.Text, "")) >= Me.MinLenght Then
      'Debug.Print Now(), "mcboAny_Timer PerformSearch"
30            PerformSearch
40        ElseIf Nz(mcboAny.Text, "") = "" Then
      'Debug.Print Now(), "mcboAny_Timer ResetRowSource"
50            ResetRowSource
              ' reset time-out for on the fly searching
60            If Me.OnTheFly Then mfrmClock.TimerInterval = 0
70        End If

ExitHere:
80       On Error GoTo 0
90       Exit Sub

ErrorHandler:
100   Select Case Err
      Case 0
110      Resume Next
120   Case Else
130      LogError Err.Number, Err.Description, Erl, "mfrmClock_Timer", "clsComboSearch"
140      Resume ExitHere
150   End Select

End Sub

Function LogError(ByVal lngErrNumber As Long, ByVal strErrDescription As String, strLine As String, _
                  strCallingProc As String, Optional strCallingModule As String, Optional vParameters = "", Optional bShowUser As Boolean = True) As Boolean
10        On Error GoTo Err_LogError
          ' Purpose: Generic error handler.
          ' Logs errors to table "ErrorLog".
          ' Arguments: lngErrNumber - value of Err.Number
          ' strErrDescription - value of err.description
          ' strLine - code line number (Erl) Erl=0 if no row number in the line
          ' strCallingProc - name of sub|function that generated the error.
          ' strCallingModule - name of code module that generated the error.
          ' vParameters - optional string: List of parameters to record.
          ' bShowUser - optional boolean: If False, suppresses display.
          Dim strMsg As String                              ' String for display in MsgBox
20        Select Case lngErrNumber
              Case 0
30                Debug.Print strCallingProc & " called error 0."
40            Case 2501                                     ' Cancelled
                  'Do nothing.
50            Case 3314, 2101, 2115                         ' Can't save.
60                If bShowUser Then
70                    strMsg = "Record cannot be saved at this time." & vbCrLf & "Complete the entry, or press <Esc> to undo."
80                    MsgBox strMsg, vbExclamation, "Error"
90                End If
100           Case Else
110               If bShowUser Then
120                   strMsg = "Error " & lngErrNumber & " (" & strErrDescription & "), Line " & strLine & " in procedure " & _
                      strCallingProc & ", module " & strCallingModule
130                   MsgBox strMsg, vbExclamation, "Error " & Now()
140               End If
      '            Set rst = CurrentDb.OpenRecordset("ErrorLog", , dbAppendOnly)
      '            rst.AddNew
      '            rst![ErrNumber] = lngErrNumber
      '            rst![ErrDescription] = Left$(strErrDescription, 255)
      '            rst![ErrDate] = Now()
      '            rst![ErrLine] = strLine
      '            rst![CallingProc] = strCallingProc
      '            rst![CallingModule] = strCallingModule
      '            rst![UserName] = GetFullUserInfo()
      '            rst![ShowUser] = bShowUser
      '            If Not IsMissing(vParameters) Then
      '                rst![Parameters] = Left(vParameters, 255)
      '            End If
      '            rst.Update
      '            rst.Close
      '            LogError = True
      '
150       End Select
          

          
              
          
Exit_LogError:
      '    Set rst = Nothing
160       Exit Function
Err_LogError:
170       strMsg = "An unexpected situation arose in your program." & vbCrLf & _
                   "Please write down the following details:" & vbCrLf & vbCrLf & _
                   "Calling Proc: " & strCallingProc & vbCrLf & _
                   "Error Number " & lngErrNumber & " in line " & strLine & vbCrLf & strErrDescription & vbCrLf & vbCrLf & _
                   "Unable to record because Error " & Err.Number & " in line " & Erl & vbCrLf & Err.Description
180       MsgBox strMsg, vbCritical, "LogError()"
190       Resume Exit_LogError
End Function