Option Compare Database
Option Explicit

' From Access 2002 Desktop Developer's Handbook
' by Litwin, Getz, and Gunderloy. (Sybex)
' Copyright  2001 .  All rights reserved.

' Incremental Search Class

' Set this constant to False to
' use ADO instead of DAO.
#Const USEDAO = True

Private WithEvents mlst As ListBox
Private WithEvents mtxt As TextBox

Private Enum ObjectType
    otNone = 0
    otTable = 1
    otDynaset = 2
End Enum
Private mot As ObjectType

#If USEDAO Then
Private mdb As DAO.Database
Private mrst As DAO.Recordset
#Else
Private mrst As ADODB.Recordset
#End If

Public DisplayField As String
Public BoundField As String
Public Index As String

Public Property Set TextBox(txt As TextBox)
    Set mtxt = txt
    mtxt.OnChange = "[Event Procedure]"
    mtxt.OnLostFocus = "[Event Procedure]"
End Property

Public Property Get TextBox() As TextBox
    Set TextBox = mtxt
End Property

Public Property Set ListBox(lst As ListBox)
    Set mlst = lst
    mlst.AfterUpdate = "[Event Procedure]"
#If USEDAO Then
    Call SetupRstDAO
#Else
    Call SetupRstADO
#End If
End Property

Public Property Get ListBox() As ListBox
    Set ListBox = mlst
End Property

#If USEDAO Then
Private Sub SetupRstDAO()
    
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Dim strSource As String
    
    ' We can handle:
    ' * Tables
    ' * Queries with no parameters
    ' * Queries with resolvable parameters.
    ' * SQL SELECT strings with no parameters.
    ' * SQL SELECT strings with resolvable parameters.
    
    On Error Resume Next
    
    strSource = mlst.RowSource
    
    ' Attempt to open a table-type recordset.
    Set mdb = CurrentDb()
    Set mrst = mdb.OpenRecordset(strSource, dbOpenTable)
    
    ' If there wasn't an error, you managed
    ' to open a table-type recordset, and all is well.
    ' Now attempt to assign an index.
    If Err =  0  Then
        mrst.Index = Index
        If Err =  0  Then
            mot = otTable
            GoTo ExitHere
        End If
    End If

    ' You're only here if you didn't manage to open a table-type
    ' recordset and set its index.
    Err.Clear
    Set qdf = mdb.QueryDefs(strSource)
    If Err.Number <>  0  Then
        ' This isn't a querydef, but probably
        ' a SQL string. This may have parameters,
        ' so try one more thing: create a new
        ' querydef, so you can evaluate its
        ' parameters.
        Err.Clear
        Set qdf = mdb.CreateQueryDef( "", strSource)
    End If
    
    ' Fill in parameter values, if possible.
    ' This will still fail for parameters that
    ' require user input.
    If Err.Number = 0 Then
        For Each prm In qdf.Parameters
            prm.Value = Eval(prm.Name)
        Next prm
        Set mrst = qdf.OpenRecordset(dbOpenDynaset)
    End If
    
    If Err.Number = 0 Then
        mot = otDynaset
    Else
        mot = otNone
    End If
    
ExitHere:
    Err.Clear
End Sub

#Else
Private Sub SetupRstADO()
    ' Open a recordset, based on the RowSource of the
    ' specified listbox.
    ' On Error Resume Next
    Dim cmd As ADODB.Command
    Dim intCount As Integer
    Dim strSource As String
    
    ' We can handle:
    ' * Tables
    ' * Queries with no parameters
    ' * Queries with resolvable parameters.
    ' * SQL SELECT strings with no parameters.
    ' * SQL SELECT strings with resolvable parameters,
    '   except with DAO wildcards.
    
    ' IMPORTANT NOTE: ADO understands " % " and " _ "
    ' as wildcard characters. Without parsing the SQL
    ' ourselves, we can't make Jet wildcards ("*" and "?")
    ' work here. Basically, if you supply SQL as the RowSource
    ' property for the list box, you cannot use "*" or "?".
    ' The problem is that Access can't handle "%" and "_"
    ' as wildcards, and ADO can't handle "*" and "?".
    ' If you use the query processor (that is, use a
    ' predefined query) as your RowSource, this won't be
    ' a problem -- Access takes care of the conversion for you.
    ' Although you COULD rewrite this code to handle
    ' this (replacing "*" and "?" in the WHERE clause)
    ' it seems like overkill. Just use a table, a query, or
    ' a simple SQL string as the RowSource and you'll be all set.
    
    ' Inline error handling is simpler here.
    On Error Resume Next
        
    Set mrst = New ADODB.Recordset
    mrst.Source = mlst.RowSource
    mrst.CursorType = adOpenStatic
    mrst.LockType = adLockOptimistic
    Set mrst.ActiveConnection = CurrentProject.Connection
        
    ' Attempt to open a table directly.
    mrst.Open Options:=adCmdTableDirect
    If Err.Number <> 0  Then
        ' That didn't succeed. Now try
        ' using adCmdTable, and this may
        ' require satisfying parameters.
        Err.Clear
        mrst.Open Options:=adCmdTable
        ' You may need to satisfy parameters. Do it here?
        If Err.Number <> 0 Then
            If Err.Number = -2147217904 Then
                Err.Clear
                Set mrst = HandleParametersADO(ct:=adCmdTable)
            End If
        End If
    End If
    If Err.Number <> 0 Then
        ' That didn't succeed. Now try
        ' using adCmdTable, and this may
        ' require satisfying parameters.
        Err.Clear
        mrst.Open Options:=adCmdText
        ' You may need to satisfy parameters. Do it here?
        If Err.Number <>  0  Then
            If Err.Number = - 2147217904  Then
                Set mrst = HandleParametersADO(ct:=adCmdText)
            Else
                GoTo HandleErrors
            End If
        End If
    End If
                 
    If Len(Index) >  0  Then
        ' Just go ahead and try.
        Err.Clear
        mrst.Index = Index
        If Err.Number = 0 Then
            mot = otTable
        Else
            ' Oops. Can't set the Index
            ' property. Therefore, clear
            ' out the Index string
            ' so later code knows there's
            ' no index in use.
            mot = otDynaset
        End If
    Else
        mot = otDynaset
    End If
    Err.Clear
    If mrst.State = adStateClosed Then
        mot = otNone
    End If

ExitHere:
    Exit Sub
    
HandleErrors:
    mot = otNone
    Err.Raise Err.Number, _
     "IncrementalSearch.SetupRstADO ", Err.Description
End Sub

Private Function HandleParametersADO( _
 Optional ct As CommandTypeEnum = adCmdTableDirect) _
 As ADODB.Recordset
    ' First, check to see the the row source
    ' has any parameters. This won't work
    ' for text you type directly into
    ' the RowSource property, but it will work
    ' for queries that have parameters based
    ' on form values. If you want to support
    ' generalized queries that have other types
    ' of parameters, you'll need to add support
    ' for that here.
    
    Dim cmd As ADODB.Command
    Dim intCount As Integer
    Dim prm As ADODB.Parameter
        
    On Error GoTo HandleErrors
        
    ' Open a new Command object.
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = CurrentProject.Connection
    cmd.CommandText = " ( " & mlst.RowSource & " ) "
    cmd.CommandType = ct
    intCount = cmd.Parameters.Count
    
    ' If there are any parameters,
    ' evaluate them now.
    If intCount > 0  Then
        For Each prm In cmd.Parameters
            prm.Value = Eval(prm.Name)
        Next prm
        ' If you've set up a Command
        ' object like this, you cannot
        ' use the Index, or the Seek method later.
        ' Indicate that this is a dynaset-like
        ' thing.
        mot = otDynaset
    End If
    Set HandleParametersADO = cmd.Execute
    
ExitHere:
    Exit Function
    
HandleErrors:
    Select Case Err.Number
        Case Else
            Err.Raise Err.Number, _
             "IncrementalSearch.HandleParametersADO ", _
             Err.Description
    End Select
    Resume ExitHere
End Function
#End If

Private Sub Class_Terminate()
    On Error Resume Next
    mrst.Close
    Set mrst = Nothing
    Set mtxt = Nothing
    Set mlst = Nothing
End Sub

Private Sub mlst_AfterUpdate()
    mtxt.Value = mlst.Value
End Sub

Private Sub mtxt_Change()
    Dim strFilter As String
    Dim strTemp As String
    Dim strDelimiter As String
    
    On Error GoTo HandleErrors
    
    DoCmd.Hourglass True
    If Len(BoundField) = 0  Then
        BoundField = DisplayField
    End If
    If Len(mtxt.Text) >  0  Then
        ' Is there text in the text box?
        ' If so, filter based on that text.
#If USEDAO Then
        Select Case mot
            Case otNone
                ' Nothing to do!
                GoTo ExitHere
            Case otDynaset
                strFilter = DisplayField & _
                 " >= " & FixQuotes(mtxt.Text)
                mrst.FindFirst strFilter
            Case otTable
                ' If there is an index set,
                ' you can use Seek.
                mrst.Seek ">=", mtxt.Text
        End Select
#Else
        Select Case mot
            Case otNone
                ' Nothing to do!
                GoTo ExitHere
            Case otDynaset
                If Len(strDelimiter) =  0  Then
                    strDelimiter = "'"
                End If
TryAgain:
                strFilter = DisplayField & _
                 " >= " & FixQuotes(mtxt.Text, strDelimiter)
                mrst.Filter = strFilter
            Case otTable
                ' If there is an index set,
                ' you can use Seek.
                mrst.Seek mtxt.Text, adSeekAfterEQ
        End Select
#End If
        ' Did we find any rows at all?
        ' If so, set the value of the
        ' list box to be the value you found.
        If Not mrst.EOF Then
            mlst.Value = mrst.Fields(BoundField)
        End If
        
#If USEDAO Then
        ' Nothing special to do, if you're using DAO.
#Else
        ' Reset the filter for next time.
        mrst.Filter = vbNullString
#End If
    Else
        ' If no text, then
        ' move to the first row,
        ' set the value to be that value
        ' (so the list box scrolls to the top)
        ' and then set the value to be Null,
        ' so nothing's selected.
        mrst.MoveFirst
        mlst.Value = mrst.Fields(BoundField)
        mlst.Value = Null
    End If

ExitHere:
    DoCmd.Hourglass False
    Exit Sub

HandleErrors:
    DoCmd.Hourglass False
    Select Case Err.Number
#If USEDAO Then
        ' No special errors, for DAO.
#Else
        Case 3001   ' The stupid ADO quotes problem.
            ' ADO can't handle parsing this stupid thing.
            ' What to do?
            
            ' If the delimiter is currently  "'"
            ' then try " # ". This might work. If there's both
            ' two apostrophes and a " # " in there, you're in trouble.
            If strDelimiter = "'"  Then
                strDelimiter =  "#" 
                Resume TryAgain
            Else
                MsgBox  "ADO is unable to parse the expression you entered." 
                Resume ExitHere
            End If
#End If
        Case Else
            Err.Raise Err.Number, _
              "IncrementalSearch.TextChange" , Err.Description
            Resume
    End Select
    Resume ExitHere
End Sub

Private Function FixQuotes(strValue As String, _
 Optional strDelimiter As String = "'") As String
    ' In:
    '   strValue:   Value to fix up.
    '   strDelimiter: (Optional) Delimiter to use.
    ' Out:
    '   Return value: the text, with delimiters fixed up.
    
    FixQuotes = _
     strDelimiter & _
     Replace(strValue, strDelimiter, strDelimiter & strDelimiter) & _
     strDelimiter
End Function

Private Sub mtxt_LostFocus()
    On Error Resume Next
    mtxt.Value = mlst.Value
End Sub

Option Compare Database
Option Explicit

' From Access 2002 Desktop Developer's Handbook
' by Litwin, Getz, and Gunderloy. (Sybex)
' Copyright  2001 .  All rights reserved.

Private mis As IncrementalSearch

Private Sub Form_Load()
    Set mis = New IncrementalSearch
    mis.DisplayField =  "Company" 
    
    ' BoundField and Index
    ' are optional. Index will only
    ' have an effect if the application
    ' can make use of it (if you ask
    ' to read data from a table directly).
    ' Use  "PrimaryKey"  if you want to specify
    ' the primary key index, and you've never
    ' changed its name.
    ' BoundField allows you to
    ' have a field to which the list box
    ' is bound, but isn't the display field.
    ' The BoundField property must match the
    ' field indexed in the Index property.
    
    ' You should set these properties
    ' before you set the ListBox property,
    ' which hooks up all the data.
    mis.BoundField =  "Company" 
    mis.Index =  "Company" 
    
    Set mis.ListBox = lstIncSrch
    Set mis.TextBox = txtIncSrch
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' This isn't really necessary, but can't hurt.
    Set mis = Nothing
End Sub