search highlights فكرة : بحث متعدد الحقول ومتعدد الكلمات مع تلوين نتيجة البحث

[Debug Ace]

بحث متعدد امكانية اختيار حقل او حقول بحث من خلال كود مركزى فى وحدة نمطية لتطبيق فكرة البحث فى اكثر من نموذج 

أقدم لكم وحدة نمطية عامة جاهزة للاستخدام تحول اى نموذج إلى محرك بحث تفاعلى بمميزات احترافية تدعم:

• البحث فوري أثناء الكتابة (Search As You Type)
• تلوين HTML للكلمات المطابقة للنتائج بلون أحمر <font color=red>  
• بحث متعدد الحقول 
• بحث متعدد الكلمات

دعم كامل للحالات المتقدمة

 

•  "ط" ← تلوين "ط" في كل الحقول
• "ط ر ة" ← تلوين "ط" + "ر" + "ة" مع فلتر AND
• "ط " ← مسافة محفوظة (تلوين فقط)
• Backspace/Delete ← فلتر يتجدد
• النقر المزدوج - Double Click ← مسح فورى
• بحث بدون نتائج ← رسالة + إلغاء

 

 

 

فى حالة عدم وجود نتائج

 

الوحدة النمطية العامة مثلا باسم : modMultipleSearchHighlights

Option Compare Database
Option Explicit

Private Const CTRL_PREFIX As String = "txt"

Public Sub InitUniversalSearch(frm As Form, fieldNames As String)
    On Error GoTo ErrHandler
    Dim arr() As String: arr = Split(fieldNames, ",")
    Dim i As Integer, fld As String

    For i = 0 To UBound(arr)
        fld = Trim(arr(i))
        frm.Controls(CTRL_PREFIX & fld).ControlSource = "=[" & fld & "]"
    Next i
    Exit Sub
    
ErrHandler:
    MsgBox "خطأ في InitUniversalSearch: " & Err.Number & " - " & Err.Description & vbCrLf & "الحقل: " & CTRL_PREFIX & fld, vbCritical, "خطأ في البحث"
End Sub

Public Sub UpdateSearch(txtBox As TextBox, frm As Form, fieldNames As String)
    On Error GoTo ErrHandler
    Dim searchValue As String
    Dim currentPos As Long

    searchValue = txtBox.text

    currentPos = Len(searchValue)

    If Len(searchValue) = 0 Then
        ResetAllHighlights frm, fieldNames
        frm.FilterOn = False

    ElseIf Right(searchValue, 1) = " " Then
        ApplyHighlightsOnly frm, fieldNames, searchValue
    Else
        ApplyHighlightsOnly frm, fieldNames, searchValue
        frm.Filter = BuildFilterSQL(fieldNames, searchValue)
        frm.FilterOn = True
        
        If frm.Recordset.RecordCount = 0 Then
            MsgBox "لا توجد نتائج لـ """ & searchValue & """" & vbCrLf & "عدد السجلات: 0", vbInformation, "نتائج البحث"
            frm.FilterOn = False
        End If
    End If

    Dim wasFocused As Boolean: wasFocused = (Screen.ActiveControl.name = txtBox.name)
    
    txtBox.SetFocus
    txtBox.SelStart = currentPos
    txtBox.SelLength = 0
    
    If Not wasFocused Then Screen.PreviousControl.SetFocus

    Exit Sub
    
ErrHandler:
    Select Case Err.Number
        Case 2185
            Debug.Print "UpdateSearch 2185 ignored: " & Err.Description
            Resume Next
            
        Case 2474, 6139
            Debug.Print "UpdateSearch ignored: " & Err.Number & " - " & Err.Description
            Resume Next
            
        Case Else
            Debug.Print "UpdateSearch Error: " & Err.Number & " - " & Err.Description
            MsgBox "خطأ في البحث: " & Err.Number & vbCrLf & Err.Description, vbCritical
            Resume ExitHandler
    End Select
    Resume Next
ExitHandler:
End Sub

Private Function ReplaceMultiple(inputText As String) As String
    Dim result As String: result = inputText
    result = Replace(result, "'", "''")
    result = Replace(result, "[", "[[]")
    result = Replace(result, "?", "[?]")
    result = Replace(result, "*", "[*]")
    result = Replace(result, """", """""")
    ReplaceMultiple = result
End Function

Private Sub ApplyHighlightsOnly(frm As Form, fieldNames As String, searchText As String)
    Dim arr() As String: arr = Split(fieldNames, ",")
    Dim words() As String: words = Split(searchText, " ")
    Dim i As Integer, w As Integer, fld As String
    Dim ctrl As Control, expr As String, safeWord As String
    
    On Error GoTo ErrHandler
    
    Application.Echo False
    
    For i = 0 To UBound(arr)
        fld = Trim(arr(i))
        Set ctrl = frm.Controls(CTRL_PREFIX & fld)
        
        On Error Resume Next
        Do While ctrl.FormatConditions.Count > 0
            ctrl.FormatConditions(1).Delete
        Loop
        On Error GoTo ErrHandler
        
        expr = "Nz([" & fld & "], """")"
        For w = 0 To UBound(words)
            If Len(Trim(words(w))) > 0 Then
                safeWord = ReplaceMultiple(Trim(words(w)))
                expr = "Replace(" & expr & ",""" & safeWord & """,""<font color=red>" & safeWord & "</font>"")"
            End If
        Next w
        
        ctrl.ControlSource = "=IIf(Len(" & expr & ")>0, " & expr & ", """")"
    Next i
    
    Application.Echo True
    Exit Sub
    
ErrHandler:
    Application.Echo True
    Debug.Print "ApplyHighlightsOnly Error: " & Err.Number & " - " & Err.Description & " (Field: " & fld & ")"
End Sub


Private Sub ResetAllHighlights(frm As Form, fieldNames As String)
    Dim arr() As String: arr = Split(fieldNames, ",")
    Dim i As Integer, fld As String, ctrl As Control
    
    On Error GoTo ErrHandler
    
    Application.Echo False
    
    For i = 0 To UBound(arr)
        fld = Trim(arr(i))
        Set ctrl = frm.Controls(CTRL_PREFIX & fld)
        
        On Error Resume Next
        Do While ctrl.FormatConditions.Count > 0
            ctrl.FormatConditions(1).Delete
        Loop
        On Error GoTo ErrHandler
        
        ctrl.ControlSource = "=[" & fld & "]"
    Next i
    
    Application.Echo True
    Exit Sub
    
ErrHandler:
    Application.Echo True
    Debug.Print "ResetAllHighlights Error: " & Err.Number & " - " & Err.Description
End
End Sub

Private Function BuildFilterSQL(fieldNames As String, searchText As String) As String
    On Error GoTo ErrHandler
    
    Dim arrFields() As String: arrFields = Split(fieldNames, ",")
    Dim words() As String: words = Split(searchText, " ")
    Dim conditions As String, i As Integer, w As Integer
    Dim wordCond As String, safeWord As String
    
    For w = 0 To UBound(words)
        If Len(Trim(words(w))) > 0 Then
            safeWord = ReplaceMultiple(Trim(words(w)))
            wordCond = ""
            
            For i = 0 To UBound(arrFields)
                If i > 0 Then wordCond = wordCond & " OR "
                wordCond = wordCond & "[" & Trim(arrFields(i)) & "] Like '*" & safeWord & "*'"
            Next i
            
            If Len(conditions) > 0 Then conditions = conditions & " AND "
            conditions = conditions & "(" & wordCond & ")"
        End If
    Next w
    
    BuildFilterSQL = IIf(Len(conditions) = 0, "", conditions)
    Exit Function
    
ErrHandler:
    BuildFilterSQL = ""
    Debug.Print "BuildFilterSQL Error: " & Err.Number & " - " & Err.Description
End Function

 

إعدادات النموذج المطلوبة

مربع نص البحث باسم :  txtSearch
مربعات نص الحقول المطلوب البحث بداخلها :

• يجب ان تكون غير منضمة : Unbound
• يجب ان تكون Rich Text
• يجب ان تكون بنفس اسم الحقل تماما وتسبقها البادئة : txt
  فمثلا فى المرفق الحقول المطلوب البحث بداخلها كانت باسم :item_na, class_no اذن اسماء مربعات النص فى النموذج لتلك الحقول سوف تكون بالاسماء: txtitem_na, txtclass_no
• مصدر بيانات النموذج (Record Source) :اسم الجدول او استعلام للجدول عادى Query/Table

الاكواد المطلوبة فى النموذج
ثابت لادراج اسماء الحقول المراد البحث بداخلها مثل

Private Const strUniversalfieldNames As String = "item_na,class_no"

وفى حدث تحميل النموذج 

Private Sub Form_Load()
    InitUniversalSearch Me, strUniversalfieldNames
End Sub

أحداث مربع النص الخاص بالبحث : txtSearch

يمكن استخدام حدث عند التغيير (Change)  أو حدث بعد التحديث (AfterUpdate) ولكن الافضل فى السرعة والاداء خاصة مع كثرة عدد السجلات او عند استخدام التطبيق فى شبكة محلية لضمان الكفائة فى الاداء والسرعة يفضل استخدام الكود التالى فى حدث بعد التحديث (AfterUpdate)
 

UpdateSearch Me.txtSearch, Me, strUniversalfieldNames

ولكن انا فقط فى المرفق استخدمت حدث عند التغيير لرؤية النتيجة فورية فقط 

وبعد ذلك يمكن عمل زر امر لعمل مسح للفلاتر ولمربع النص او كود فى حدث النقر المزدوج لمربع البحث : txtSearch

Me.txtSearch.Value = ""
UpdateSearch Me.txtSearch, Me, strUniversalfieldNames

واخيرا المرفق 

 

Search Highlights.accdb

تم تعديل منذ 2 ساعات بواسطه Debug Ace