filter inside the combobox شخابيط وأفكار و حلول :تصفية مربع سرد (ComboBox) لنفسه اثناء الكتابة مع دعم حقول متعددة

[ابو جودي]

السلام عليكم ورحمة الله

أشارك معكم اليوم أكواد داخل وحدة نمطية عامة تم تطويرها لتصفية محتويات أي مربع سرد (ComboBox) في أي نموذج بشكل ديناميكي بمجرد الكتابة داخل مربع التحرير والسرد 

تصفية ديناميكية:

يدعم التصفية المتعددة باستخدام أكثر من حقل (مثل الاسم + الرقم القومي)

تدعم التصفية على حقل واحد أو حقول متعددة باستخدام نمط LIKE '*...*' وذلك لتتم التصفية بناء على اى جزء من الكلمة

الكود داخل الوحده النمطية العامة

Option Compare Database
Option Explicit

Private dictRowSources As Object
Private strLastFilterValue As String
Private strLastComboName As String

Private Sub EnsureDictionary()
    If dictRowSources Is Nothing Then
        Set dictRowSources = CreateObject("Scripting.Dictionary")
    End If
End Sub

Public Sub ClearComboMemory(ByVal frm As Access.Form)
    Dim strKey As Variant
    Call EnsureDictionary
    For Each strKey In dictRowSources.Keys
        If Left(strKey, Len(frm.Name) + 1) = frm.Name & "." Then
            dictRowSources.Remove strKey
        End If
    Next
End Sub

Public Sub FilterCombo(ByVal frm As Access.Form, _
                       ByVal strComboName As String, _
                       Optional ByVal strFilterField As String = "")
    Dim cmb                 As Access.ComboBox
    Dim strSourceSQL        As String
    Dim strFilterValue      As String
    Dim strFilteredSQL      As String
    Dim strOrderByClause    As String
    Dim strKey              As String
    Dim objRegex            As Object
    Dim objMatches          As Object
    Dim arrFilterFields     As Variant
    Dim strWhereClause      As String
    Dim i                   As Long

    On Error GoTo ExitWithError

    ' التحقق من صحة النموذج وعنصر التحكم
    If frm Is Nothing Then
        MsgBox "النموذج غير صالح.", vbExclamation
        Exit Sub
    End If

'    Debug.Print "Form: " & frm.Name
'    Debug.Print "ComboBox: " & strComboName

    Set cmb = frm.Controls(strComboName)

    ' التحقق من مصدر البيانات
    Call EnsureDictionary
    strKey = frm.Name & "." & cmb.Name

    If dictRowSources.Exists(strKey) Then
        strSourceSQL = dictRowSources(strKey)
    Else
        strSourceSQL = Trim(Replace(cmb.RowSource & "", ";", "")) ' إزالة الفاصلة المنقوطة
'        Debug.Print "RowSource: " & strSourceSQL
        If Len(strSourceSQL) = 0 Then
            MsgBox "مصدر البيانات غير صالح.", vbExclamation
            Exit Sub
        End If
        dictRowSources.Add strKey, strSourceSQL
    End If

    ' إعادة تعيين المصدر إذا لم يتم توفير حقل تصفية
    If Len(strFilterField) = 0 Then
        If cmb.RowSource <> strSourceSQL Then
            cmb.RowSource = strSourceSQL
        End If
        cmb.Requery
        cmb.Dropdown
        strLastFilterValue = ""
        strLastComboName = strComboName
        Exit Sub
    End If

    ' التحقق من نوع عنصر التحكم النشط
    If TypeOf Screen.ActiveControl Is Access.TextBox Or TypeOf Screen.ActiveControl Is Access.ComboBox Then
        strFilterValue = Nz(Screen.ActiveControl.Text, vbNullString)
'        Debug.Print "ActiveControl: " & Screen.ActiveControl.Name
'        Debug.Print "FilterValue: " & strFilterValue
    Else
'        Debug.Print "ActiveControl is not TextBox or ComboBox"
        If cmb.RowSource <> strSourceSQL Then
            cmb.RowSource = strSourceSQL
        End If
        cmb.Requery
        cmb.Dropdown
        strLastFilterValue = ""
        strLastComboName = strComboName
        Exit Sub
    End If

    ' إعادة تعيين المصدر إذا كانت القيمة المصفاة فارغة
    If Len(strFilterValue) = 0 Then
        If cmb.RowSource <> strSourceSQL Then
            cmb.RowSource = strSourceSQL
        End If
        cmb.Requery
        cmb.Dropdown
        strLastFilterValue = ""
        strLastComboName = strComboName
        Exit Sub
    End If

    ' التحقق مما إذا كانت القيمة المصفاة أو ComboBox قد تغيرت
    If strFilterValue = strLastFilterValue And strComboName = strLastComboName Then
        cmb.Requery
        cmb.Dropdown
        Exit Sub
    End If

    ' استخدام Regex لاستخراج ORDER BY
    Set objRegex = CreateObject("VBScript.RegExp")
    With objRegex
        .Global = True
        .IgnoreCase = True
        .Pattern = "\s*ORDER\s+BY\s+.*$"
    End With

    Set objMatches = objRegex.Execute(strSourceSQL)
    If objMatches.Count > 0 Then
        strOrderByClause = objMatches(0).Value
        strSourceSQL = Trim(Replace(strSourceSQL, strOrderByClause, ""))
    Else
        strOrderByClause = ""
    End If
'    Debug.Print "SourceSQL: " & strSourceSQL
'    Debug.Print "OrderBy: " & strOrderByClause

    ' التحقق من الحقول وإنشاء شرط WHERE لحقول متعددة
    If Len(strFilterField) > 0 Then
        arrFilterFields = Split(strFilterField, ",")
        strWhereClause = ""
        For i = LBound(arrFilterFields) To UBound(arrFilterFields)
            Dim strField As String
            strField = Trim(arrFilterFields(i))
            If Len(strField) > 0 Then
                If Len(strWhereClause) > 0 Then strWhereClause = strWhereClause & " OR "
                strWhereClause = strWhereClause & strField & " LIKE '*" & Replace(strFilterValue, "'", "''") & "*'"
            End If
        Next i

        If Len(strWhereClause) = 0 Then
            MsgBox "تعبير التصفية غير صالح: " & strFilterField, vbExclamation
            Exit Sub
        End If

        On Error Resume Next
        strFilteredSQL = strSourceSQL & " WHERE (" & strWhereClause & ")" & strOrderByClause
'        Debug.Print "FilteredSQL: " & strFilteredSQL
        cmb.RowSource = strFilteredSQL
        If Err.Number <> 0 Then
            MsgBox "تعبير التصفية غير صالح: " & strFilterField & vbCrLf & "Error: " & Err.Description, vbExclamation
            On Error GoTo ExitWithError
            Exit Sub
        End If
        On Error GoTo ExitWithError
    Else
        strFilteredSQL = strSourceSQL & strOrderByClause
        cmb.RowSource = strFilteredSQL
    End If

    ' تعيين المصدر المصفى وتحديث واجهة المستخدم
    cmb.Requery
    cmb.Dropdown

    strLastFilterValue = strFilterValue
    strLastComboName = strComboName
    Exit Sub

ExitWithError:
    Select Case Err.Number
        Case 2118
            Resume Next
        Case Else
            MsgBox "حدث خطأ أثناء التصفية: " & Err.Number & " | " & Err.Description, vbExclamation
    End Select
End Sub

الاستدعاء فى النموذج 

في حدث Click : لإعادة تحميل القائمة الأصلية لمربع السرد عند الضغط عليه

' في حدث Click
Private Sub ComboBoxName_Click()
    FilterCombo Me, "ComboBoxName"
End Sub

وايضا في حدث KeyUp : لتصفية القيم أثناء الكتابة في مربع السرد حسب حقل واحد

' في حدث KeyUp
Private Sub ComboBoxName_KeyUp(KeyCode As Integer, Shift As Integer)
    FilterCombo Me, "ComboBoxName", "FieldName"
End Sub

مع امكانية في حدث KeyUp : لتصفية القيم أثناء الكتابة في مربع السرد حسب أكثر من حقل

' في حدث KeyUp لعمل التصفية المتعددة
Private Sub ComboBoxName_KeyUp(KeyCode As Integer, Shift As Integer)
    FilterCombo Me, "ComboBoxName", "FieldName, FieldName2"
End Sub

 

تحياتى

Filter inside the Combobox.accdb

[hanan_ms]

 ؟! تمة التجربة مرفق يأخذ العربي فقط                                                                                                                                                                                                              

استخدمة المرفق لعرض معاينة التقرير في النموذج يتحجم ويتغير طبقا للكود  فقط هل لديك دالة تقسم بعد الاستعلام او الفلترة الى فلترة لعرض السجلات في التقرير وتعلم ان التقرير لحد معين من السجلات يمكن يعرضها او ينهار ويغلق ؟! , فنقسم كل 5000 الف سجل هل المعلومة صحيحة وهل لديك دالة 

 

استاذ @ابو جودي ❤️🌹☕ \ نستفيد من عصير خبرتك 😇

 

تحميل المرفق 

https://www.mediafire.com/file/0j7r9h3j0bk8rkw/Report_after_print_In_Form_with_tools_V1.mp4/file