在MS Access 2019中用VBA实现表单长文本搜索内容选中

问题背景 #

MS Access表单底部导航栏自带的搜索框尺寸过小，自行实现搜索功能时，发现长文本字段无法通过SetFocus、SelStart、SelLength方法选中搜索到的内容，但原生搜索功能可正常实现该效果。

问题原因 #

Access中设置为富文本格式的长文本字段，对应的表单控件是RichTextBox（属于Microsoft Rich Textbox Control组件），而非普通的TextBox。直接调用标准文本框的选择方法会因控件类型不匹配或未完成激活而失效，而原生搜索通过内部逻辑正确处理了富文本控件的文本选择。

解决代码 #

修改原搜索按钮的VBA代码，增加对RichTextBox控件的判断与处理逻辑：

' 全局变量：记录上次搜索的位置
Dim lngDernierIndex As Long

Private Sub btnRechercher_Click()
    Dim rst As DAO.Recordset
    Dim strRecherche As String
    Dim strField As String
    Dim lngStart As Long
    Dim arrChamps() As String
    Dim i As Integer
    Dim trouve As Boolean
    Dim ctl As Control
    
    ' 获取搜索框输入内容
    strRecherche = Me.txtRecherche.Value
    
    ' 定义需要搜索的字段列表
    arrChamps = Split("Description,NomCommun,NomScientifique,Cohabitation,Reproduction,Maladies,Dangers,Mutations,Classe,Ordre,Famille", ",")
    
    ' 克隆表单记录集
    Set rst = Me.RecordsetClone

    ' 若搜索关键词变更，重置搜索起始位置
    If Me.txtRecherche.Tag <> strRecherche Then
        lngDernierIndex = 0
        Me.txtRecherche.Tag = strRecherche
    End If
    
    ' 无记录时提示
    If rst.RecordCount = 0 Then
        MsgBox "数据库中无任何记录。", vbInformation
        Exit Sub
    End If

    ' 搜索位置超出记录总数时重置并提示
    If lngDernierIndex >= rst.RecordCount Then
        MsgBox "已到达记录末尾，将重新开始搜索。", vbInformation
        lngDernierIndex = 0
        Exit Sub
    End If
    
    ' 定位到上次搜索结束的位置
    rst.AbsolutePosition = lngDernierIndex
    
    trouve = False
    Do Until rst.EOF
        ' 遍历所有指定字段
        For i = LBound(arrChamps) To UBound(arrChamps)
            strField = arrChamps(i)
            
            ' 检查字段是否存在
            If FieldExists(rst, strField) Then
                ' 字段非空时执行搜索
                If Not IsNull(rst(strField)) Then
                    lngStart = InStr(1, rst(strField).Value, strRecherche, vbTextCompare)
                    If lngStart > 0 Then
                        ' 跳转到匹配的记录
                        Me.Bookmark = rst.Bookmark
                        
                        ' 获取对应字段的表单控件
                        Set ctl = Me.Controls(strField)
                        
                        ' 处理普通文本框和富文本框的文本选择
                        Select Case ctl.Class
                            Case "TextBox"
                                ctl.SetFocus
                                ctl.SelStart = lngStart - 1
                                ctl.SelLength = Len(strRecherche)
                            Case "RichTextCtrl"
                                ' 富文本框需先激活并等待控件就绪
                                ctl.SetFocus
                                DoEvents ' 确保控件完成激活
                                ctl.SelStart = lngStart - 1
                                ctl.SelLength = Len(strRecherche)
                        End Select
                        
                        trouve = True
                        Exit For
                    End If
                End If
            End If
        Next i
        
        If trouve Then Exit Do
        rst.MoveNext
    Loop
    
    ' 未找到匹配记录时重置位置
    If Not trouve Then
        MsgBox "未找到其他匹配记录。", vbInformation
        lngDernierIndex = 0
    Else
        ' 记录本次搜索结束的位置，用于下次搜索
        lngDernierIndex = rst.AbsolutePosition + 1
    End If
    
    ' 释放资源
    rst.Close
    Set rst = Nothing
    Set ctl = Nothing
End Sub

' 检查字段是否存在于记录集中的辅助函数
Function FieldExists(rst As DAO.Recordset, fieldName As String) As Boolean
    On Error Resume Next
    FieldExists = (rst.Fields(fieldName).Name <> "")
    On Error GoTo 0
End Function

关键修改点 #

• 新增Select Case判断控件类型，区分普通TextBox和富文本RichTextCtrl
• 对富文本框增加DoEvents方法，确保控件在设置焦点后完成激活，再执行文本选择
• 统一通过ctl变量引用控件，代码更简洁易维护

内容的提问来源于stack exchange，提问作者Nolmê Informatique