هدية : شخابيط و أفكار : إجراء مركزي لإدارة الأخطاء

[ابو جودي]

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

كل عام وانتم بخيــر

يأتى شهر الخير ومعه البركات

أقدم اليكم هدية قيمة بكل ما تحمل الكلمة من معنى فى هذا الموضوع من أفكار  وأكواد وفوائد هامة لا غنى عنها مطلقا

ذات مرة شاركت بكتابة موضوع بخصوص انشاء الجداول واضافة الحقول وخصائصها برمجيا

وهذا هو الموضوع 

واستكمالا لما تم طرحه فى هذا الموضوع السابق الاشارة اليه 

تعديل وتطوير بعض الاكواد والافكار لاضفاء مرونة واحترافيه وكفائه اكبر 

الفائده : 
امكانية عمل الجداول الاساسية بشكل ديناميكى من خلال الكود دون أدنى تدخل من المستخدم 

الغرض : 
سهول ومرونة وحفاظا على البيانات والاعدادت الاساسية للتطبيق 
 

طيب علشان سامع واحد هناك بيقول ايه يعم ده دا عمل الجدول اسهل واسرع من وجع الدماغ ده 
هو كلامه صح ... عارف
ولكــــن لتوضيح المميزات والآفكار دعونا نمضى فى هذا الموضوع 

وهذه احد الفوائد العظيمة و الهامة على سبيل المثال فقط وليس الحصر 

الفكرة كالاتى عمل دالة مركزية للاخطاء داخل الأكواد
الفوائد العظيمه من ورائها
مرونة فائقة : 
✔ إنشاء جداول بشكل ديناميكى لحفظ وتتبع ارقام و وصف و أماكن الأخطاء داخل الإجراءات و زوايا التطبيق المختلفة .....
✔ إنشاء جداول بشكل ديناميكى للتحكم فى إعدادت التعامل مع الدالة المركزية 
✔ إعادة البيانات الاعدادت داخل الجدول اذا تم العبث بها  " قسراً "
✔ إعدة الحقول والبيانات اذا تم حذفها" قسراً "
✔ إعادة إنشاء الجداول بشكل ديناميكى مرة أخرى أخرى أذا تم حذفها " قسراً "

لنمضى قدما بع هذه المقدمة 

- وحدة نمطية عامة رئيسية باسم : basTablesCreator
الأكواد بداخل الوحدة النمطية

Option Compare Database
Option Explicit

' متغير عام لتخزين الحقول باستخدام القاموس
Public Fields As Object

' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات
Public Enum FieldTypes
    dbBoolean = 1          ' نوع الحقل: Yes/No (قيمة منطقية)
    dbByte = 2             ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255)
    dbInteger = 3          ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767)
    dbLong = 4             ' نوع الحقل: Long Integer (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647)
    dbCurrency = 5         ' نوع الحقل: Currency (عدد عشري بدقة عالية للحسابات المالية)
    dbSingle = 6           ' نوع الحقل: Single (عدد عشري بدقة بسيطة)
    dbDouble = 7           ' نوع الحقل: Double (عدد عشري بدقة مزدوجة)
    dbDate = 8             ' نوع الحقل: Date/Time (تاريخ ووقت)
    dbText = 10            ' نوع الحقل: Text (نص عادي يصل إلى 255 حرفًا)
    dbMemo = 12            ' نوع الحقل: Memo (نص طويل جدًا)
    dbAutoNumber = 15      ' نوع الحقل: AutoNumber (ترقيم تلقائي)
    dbBinary = 128         ' نوع الحقل: Binary (بيانات ثنائية صغيرة)
    dbVarBinary = 205      ' نوع الحقل: OLE Object (بيانات ثنائية كبيرة مثل ملفات OLE)
    dbAttachment = 101     ' نوع الحقل: Attachment (ملفات مرفقة)
    dbBigInt = 16          ' نوع الحقل: BigInt (عدد صحيح كبير جدًا، 64 بت)
    dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات)
End Enum

' دالة لإنشاء قاموس جديد عند الحاجة إليه
Public Function CreateDictionary() As Object
    Set CreateDictionary = CreateObject("Scripting.Dictionary")
End Function

' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة
Public Sub AddFieldToDictionary(fieldName As String, _
                                fieldType As FieldTypes, _
                                Optional fieldSize As Long = 0, _
                                Optional fieldFormat As String = "", _
                                Optional defaultValue As Variant = Null, _
                                Optional fieldCaption As String = "", _
                                Optional fieldDescription As String = "")
                                
    Dim fieldDict As Object
    Set fieldDict = CreateDictionary()

    With fieldDict
        .Add "Name", fieldName
        .Add "Type", fieldType
        .Add "Size", fieldSize
        .Add "Caption", fieldCaption
        .Add "Description", fieldDescription
        .Add "DefaultValue", defaultValue
        .Add "Format", fieldFormat
    End With

    If Fields Is Nothing Then Set Fields = CreateDictionary()
    Set Fields(fieldName) = fieldDict
End Sub

' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات
Public Function IsTableExist(TableName As String) As Boolean
    Dim tdf As DAO.TableDef
    For Each tdf In CurrentDb.TableDefs
        If tdf.Name = TableName Then
            IsTableExist = True
            Exit Function
        End If
    Next tdf
    IsTableExist = False
End Function

' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا
Public Sub CreateNewTable(TableName As String, Fields As Object)
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim fieldDict As Object
    Dim key As Variant

    ' الحصول على قاعدة البيانات الحالية
    Set db = CurrentDb()

    ' التحقق مما إذا كان الجدول موجودًا بالفعل
    If IsTableExist(TableName) Then
        db.TableDefs.Delete TableName
        db.TableDefs.Refresh
    End If

    ' إنشاء كائن TableDef جديد
    Set tdf = db.CreateTableDef(TableName)

    ' التأكد من أن القاموس غير فارغ
    If Fields Is Nothing Then Exit Sub

    ' إضافة الحقول إلى الجدول
    For Each key In Fields.Keys
        ' الحصول على القاموس الخاص بكل حقل
        Set fieldDict = Fields(key)

        ' التحقق من صحة البيانات
        If fieldDict.Exists("Name") And fieldDict.Exists("Type") Then
            ' إنشاء الحقل
            If fieldDict("Type") <> dbAutoNumber Then
                Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"))
                
                ' تعيين الحجم إذا كان الحقل نصيًا
                If fieldDict("Type") = dbText Then
                    If fieldDict.Exists("Size") And fieldDict("Size") > 0 Then
                        fld.Size = fieldDict("Size")
                    Else
                        MsgBox "حجم الحقل النصي غير صالح!", vbCritical
                        Exit Sub
                    End If
                End If
            Else
                ' إنشاء حقل AutoNumber
                Set fld = tdf.CreateField(fieldDict("Name"), dbLong)
                fld.Attributes = dbAutoIncrField
            End If

            ' تعيين القيمة الافتراضية إذا كانت مدعومة
            If fieldDict.Exists("DefaultValue") Then
                On Error Resume Next
                fld.defaultValue = fieldDict("DefaultValue")
                On Error GoTo 0
            End If

            ' إضافة الحقل إلى الجدول
            tdf.Fields.Append fld
        Else
            MsgBox "خطأ: بيانات الحقل غير مكتملة!", vbCritical
            Exit Sub
        End If
    Next key

    ' إضافة الجدول إلى قاعدة البيانات
    db.TableDefs.Append tdf
    db.TableDefs.Refresh
End Sub

' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر
Public Function CloseTableIfNecessary(TableName As String) As Boolean
    On Error Resume Next
    DoCmd.Close acTable, TableName
    CloseTableIfNecessary = (Err.Number = 0)
    On Error GoTo 0
End Function

' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول
Public Sub SetFieldProperties(TableName As String, Fields As Object)
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim fieldDict As Object
    Dim key As Variant
    Dim prop As DAO.Property

    ' الحصول على قاعدة البيانات الحالية
    Set db = CurrentDb()
    ' الحصول على الكائن TableDef للجدول الذي سيتم التحديث فيه
    Set tdf = db.TableDefs(TableName)

    ' التأكد من أن القاموس غير فارغ
    If Fields Is Nothing Then Exit Sub

    ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول
    For Each key In Fields.Keys
        Set fieldDict = Fields(key)

        ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه
        If IsFieldExist(tdf, fieldDict("Name")) Then
            Set fld = tdf.Fields(fieldDict("Name"))

            ' إضافة أو تحديث التسمية (Caption) إذا كانت موجودة
            If fieldDict.Exists("Caption") And fieldDict("Caption") <> "" Then
                On Error Resume Next
                fld.Properties.Delete "Caption" ' حذف التسمية الحالية إذا كانت موجودة
                On Error GoTo 0
                ' إضافة التسمية الجديدة
                fld.Properties.Append fld.CreateProperty("Caption", dbText, fieldDict("Caption"))
            End If

            ' إضافة أو تحديث الوصف (Description) إذا كان موجودًا
            If fieldDict.Exists("Description") And fieldDict("Description") <> "" Then
                On Error Resume Next
                fld.Properties.Delete "Description" ' حذف الوصف الحالي إذا كان موجودًا
                On Error GoTo 0
                ' إضافة الوصف الجديد
                fld.Properties.Append fld.CreateProperty("Description", dbText, fieldDict("Description"))
            End If

            ' إضافة أو تحديث التنسيق (Format) إذا كان موجودًا
            If fieldDict.Exists("Format") And fieldDict("Format") <> "" Then
                On Error Resume Next
                fld.Properties.Delete "Format" ' حذف التنسيق الحالي إذا كان موجودًا
                On Error GoTo 0
                ' إضافة التنسيق الجديد
                fld.Properties.Append fld.CreateProperty("Format", dbText, fieldDict("Format"))
            End If

            ' تحديث القيمة الافتراضية (DefaultValue) بشكل صارم
            If fieldDict.Exists("DefaultValue") Then
                On Error Resume Next
                fld.defaultValue = Null ' حذف القيمة الافتراضية الحالية إذا كانت موجودة
                On Error GoTo 0

                ' إضافة القيمة الافتراضية بناءً على نوع الحقل
                If Not IsNull(fieldDict("DefaultValue")) And Trim(Nz(fieldDict("DefaultValue"), "")) <> "" Then
                    ' التحقق من أن الحقل ليس من النوع AutoNumber
                    If fieldDict("Type") <> dbAutoNumber Then
                        Select Case fieldDict("Type")
                            Case dbText, dbMemo, dbAttachment
                                ' للحقول النصية، نقوم بتحويل القيمة إلى سلسلة
                                fld.defaultValue = CStr(fieldDict("DefaultValue"))
                            Case dbInteger, dbLong, dbBigInt, dbByte
                                ' للحقول العددية، نقوم بتحويل القيمة إلى رقم
                                fld.defaultValue = CStr(Nz(fieldDict("DefaultValue"), 0))
                            Case dbDate
                                ' للحقول التاريخية، نقوم بتحويل القيمة إلى تنسيق تاريخ
                                fld.defaultValue = Format(Nz(fieldDict("DefaultValue"), Now()), "yyyy-mm-dd hh:mm:ss")
                            Case Else
                                ' لأي نوع آخر، نقوم بتحويل القيمة إلى سلسلة
                                fld.defaultValue = CStr(fieldDict("DefaultValue"))
                        End Select
                    Else
                        ' إذا كان الحقل من النوع AutoNumber، لا نقوم بتعيين قيمة افتراضية
                        ' Debug.Print "Skipping defaultValue for AutoNumber field: " & fieldDict("Name")
                    End If
                Else
                    ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية
                    If fieldDict("Type") <> dbAutoNumber Then
                        fld.defaultValue = ""
                    End If
                End If
            End If
        End If
    Next key
End Sub

' دالة لبناء شرط البحث
Private Function BuildCriteria(record As Object, uniqueFields As Variant, TableName As String) As String
    Dim criteria As String
    Dim fieldName As String
    Dim fieldValue As Variant
    Dim fieldType As DAO.DataTypeEnum
    Dim fieldIndex As Variant

    ' التحقق من أن record هو قاموس
    If Not TypeOf record Is Object  Or TypeName(record) <> "Dictionary" Then
        BuildCriteria = ""
        Exit Function
    End If

    ' بناء شرط البحث باستخدام الحقول الفريدة
    criteria = ""
    For Each fieldIndex In uniqueFields
        fieldName = Trim(fieldIndex)
        If record.Exists(fieldName) Then
            fieldValue = record(fieldName)

            ' التحقق من أن القيمة ليست Null أو فارغة
            If Not IsNull(fieldValue) And Trim(CStr(fieldValue)) <> "" Then
                If criteria <> "" Then criteria = criteria & " AND "

                ' الحصول على نوع الحقل من الجدول
                fieldType = GetFieldType(TableName, fieldName)

                ' التعامل مع القيم بناءً على نوع الحقل
            ' التعامل مع القيم بناءً على نوع الحقل
            Select Case fieldType
                Case dbText, dbMemo
                    criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'"
                Case dbInteger, dbLong, dbByte, dbSingle, dbDouble, dbCurrency, dbBigInt
                    criteria = criteria & "[" & fieldName & "] = " & fieldValue
                Case dbBoolean
                    criteria = criteria & "[" & fieldName & "] = " & IIf(fieldValue, -1, 0)
                Case dbDate
                    criteria = criteria & "[" & fieldName & "] = #" & Format(fieldValue, "yyyy-mm-dd hh:mm:ss") & "#"
                Case Else
                    criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'"
            End Select
            End If
        End If
    Next fieldIndex

    ' إذا لم يتم بناء شرط البحث، يعني أن القاموس فارغ
    If criteria = "" Then
        BuildCriteria = ""
    Else
        BuildCriteria = criteria
    End If
End Function

' للحصول على نوع الحقل
Private Function GetFieldType(TableName As String, fieldName As String) As DAO.DataTypeEnum
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field

    Set db = CurrentDb()
    Set tdf = db.TableDefs(TableName)

    On Error Resume Next
    Set fld = tdf.Fields(fieldName)
    If Err.Number <> 0 Then
        GetFieldType = dbText ' نوع افتراضي إذا لم يتم العثور على الحقل
        Exit Function
    End If
    On Error GoTo 0

    GetFieldType = fld.Type
End Function

' دالة مساعدة لتنسيق القيمة حسب النوع
Private Function FormatFieldValue(value As Variant) As String
    If IsDate(value) Then
        FormatFieldValue = "#" & Format(value, "mm/dd/yyyy hh:nn:ss AM/PM") & "#"
    ElseIf IsNumeric(value) Then
        FormatFieldValue = CStr(value)
    Else
        FormatFieldValue = "'" & Replace(CStr(value), "'", "''") & "'"
    End If
End Function

' دالة لتحديد ما إذا كان الحقل من نوع AutoNumber
Function IsAutoNumberField(fld As DAO.Field) As Boolean
    IsAutoNumberField = (fld.Type = dbAutoNumber)
End Function

' الإجراء الرئيسي لإنشاء أو تحديث الجدول وإدخال البيانات
Public Sub CreateOrModifyTableAndInsertData(TableName As String, Fields As Object, _
                                            Optional records As Collection = Nothing, _
                                            Optional uniqueFieldNames As String = "", _
                                            Optional bAddData As Boolean = False)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim record As Object
    Dim uniqueFields() As String
    Dim criteria As String

    Set db = CurrentDb()

    '--- 1. إغلاق الجدول إذا كان مفتوحًا ---
    If Not CloseTableIfNecessary(TableName) Then
        MsgBox "لا يمكن تعديل الجدول لأنه مفتوح.", vbExclamation
        Exit Sub
    End If

    '--- 2. إنشاء الجدول إذا لم يوجد ---
    If Not IsTableExist(TableName) Then
        CreateNewTable TableName, Fields
    Else
        '--- 3. تحديث الهيكل فقط إذا كان bAddData = True ---
        If bAddData Then
            Dim tdf As DAO.TableDef
            Set tdf = db.TableDefs(TableName)
            EnsureFieldsExist tdf, Fields
        End If
    End If

    '--- 4. تطبيق خصائص الحقول ---
        SetFieldProperties TableName, Fields

    '--- 5. معالجة البيانات ---
    If bAddData And Not records Is Nothing And uniqueFieldNames <> "" Then
        uniqueFields = Split(uniqueFieldNames, ", ")
    
        Set rs = db.OpenRecordset(TableName, dbOpenDynaset)
    
        For Each record In records
            ' التحقق من أن record هو قاموس
            If TypeOf record Is Object  And TypeName(record) = "Dictionary" Then
                ' بناء شرط البحث مع تمرير اسم الجدول
                criteria = BuildCriteria(record, uniqueFields, TableName)
                ' Debug.Print criteria
                
                ' التحقق من صحة الشرط
                If criteria <> "" Then
                    rs.FindFirst criteria
    
                    If rs.NoMatch Then
                        rs.AddNew
                    Else
                        rs.Edit
                    End If
    
                    ' تحديث القيم
                    Dim key As Variant
                    For Each key In record.Keys
                        If Not IsAutoNumberField(rs.Fields(key)) Then
                            rs(key) = record(key)
                        End If
                    Next key
    
                    rs.Update
                Else
                    ' Debug.Print "Invalid criteria for record. Skipping..."
                End If
            Else
                ' Debug.Print "Element in records is not a valid Dictionary. Skipping..."
            End If
        Next record
    
        rs.Close
    End If
    
    Application.RefreshDatabaseWindow
End Sub

' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول
Public Function IsFieldExist(tdf As DAO.TableDef, fieldName As String) As Boolean
    Dim fld As DAO.Field
    For Each fld In tdf.Fields
        If fld.Name = fieldName Then
            IsFieldExist = True
            Exit Function
        End If
    Next fld
    IsFieldExist = False
End Function

' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة
Public Sub EnsureFieldsExist(tdf As DAO.TableDef, Fields As Object)
    Dim fieldDict As Object
    Dim fld As DAO.Field
    Dim key As Variant
    ' التأكد من أن القاموس غير فارغ
    If Fields Is Nothing Then Exit Sub
    
    For Each key In Fields.Keys
        Set fieldDict = Fields(key)
        
        ' التحقق من عدم وجود حقل بنفس الاسم
        If Not IsFieldExist(tdf, fieldDict("Name")) Then
            ' إنشاء الحقل بناءً على النوع
            If fieldDict("Type") <> dbAutoNumber Then
                Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size"))
            Else
                Set fld = tdf.CreateField(fieldDict("Name"), dbLong)
                fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber
            End If
            
            ' تعيين القيمة الافتراضية إذا كانت محددة
            If Not IsNull(fieldDict("DefaultValue")) And fieldDict("DefaultValue") <> "" Then
                fld.defaultValue = fieldDict("DefaultValue")
            End If
            
            ' إضافة الحقل إلى الجدول
            tdf.Fields.Append fld
        End If
    Next key
End Sub

' دالة مساعدة للتحقق من القيم الفارغة أو Null
Private Function IsEmptyOrNull(value As Variant) As Boolean
    IsEmptyOrNull = IsNull(value) Or Trim(CStr(value)) = ""
End Function

الغرض منها : 
✔ هى التى تحتوى على الجراءات والوظائف الاساسية لعملية إنشاء الجداول والحقول وخصائص الحقول

 

- وحدة نمطية عامة ثانوية باسم : basTablesInitialization
الاكواد بداخلها 

Option Compare Database
Option Explicit

' متغير لكتابة اسم الحقل/الحقول الفريدة لضمان عدم تكرار السجلات
Dim uniqueFields As String

' هذا الإجراء يقوم بتهيئة الجدول الخاص بتسجيل الأخطاء
Public Sub InitializeTableErrorLog()
    Dim tblName As String
    
    ' اسم جدول تسجيل الأخطاء
    tblName = "tblErrorLog"

    ' إنشاء القاموس لاحتواء الحقول
    Set Fields = CreateDictionary()
    
    ' إضافة الحقول ومعلومات كل حقل:
    ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف)
    AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي"
    AddFieldToDictionary "ErrorDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "وقت حدوث الخطأ", "الغرض :تسجيل وقت و تاريخ حدوث الخطأ"
    AddFieldToDictionary "Source", dbText, 255, "@[red]", , "الإجراء/الوظيفة", "الغرض :اسم الإجراء/الوظيفة/النموذج/الوحده النمطية/التقرير الذي حدث فيه الخطأ"
    AddFieldToDictionary "ErrorNumber", dbLong, , , , "رقم الخطأ", "الغرض :تسجيل رقم الخطأ المرتبط بـ الإجراء/الوظيفة Err.Number"
    AddFieldToDictionary "ErrorDescription", dbText, 255, "@[Blue]", , "وصف الخطأ", "الغرض :تسجيل الوصف التفصيلي للخطأ كما يظهر في: Err.Description"
    AddFieldToDictionary "UserName", dbText, 100, "", , "حدث الخطأ مع المستخدم", "حقل : يحتوى على سجل من: Environ USERNAME"
    AddFieldToDictionary "CallExecutionTrace", dbMemo, , , , "تسلسل تنفيذ الأكواد", "الغرض :تسجيل جميع الإجراءات التي تم تنفيذها قبل حدوث الخطأ، مما يسهل تتبع مصدر المشكلة"
    AddFieldToDictionary "AdditionalInfo", dbText, 255, , , "معلومات إضافيه", "الغرض :تسجيل معلومات إضافية مخصصة يضيفها المطور عند استدعاء قيم متغيرات مهمة عند حدوث الخطأ"

    CreateOrModifyTableAndInsertData tblName, Fields, , , False

End Sub

Public Sub InitializeErrorSettingsTable()
    Dim tblName As String
    
    ' اسم جدول أعدادت الوظيفة المركزية للتعامل مع الأخطاء
    tblName = "tblErrorSettings"

    ' إنشاء القاموس لاحتواء الحقول
    Set Fields = CreateDictionary()

    ' إضافة الحقول ومعلومات كل حقل:
    ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف)
    AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي"
    AddFieldToDictionary "ConfigKey", dbInteger, , , , "رقم فريد للإعداد", "الغرض :تسجيل رقم فريد لكل الإعدادات في النظام للقيم المعرفة"
    AddFieldToDictionary "ConfigValue", dbBoolean, , , False, "قيمة الإعداد", "الغرض :تسجيل القيمة المرتبطة بمفتاح الإعدادات: (تفعيل / تعطيل الإعداد)"
    AddFieldToDictionary "ConfigDescription", dbText, 100, "@[red]", , "وصف الإعداد", "الغرض :تسجيل الوصف والغرض من الإعدادات"
    
    ' إنشاء مجموعة السجلات الافتراضية
    Dim records As New Collection
    
    ' إضافة السجلات
    ' السجل الأول
    Dim record1 As Object, record2 As Object, record3 As Object
    Set record1 = CreateDictionary()
    record1("ConfigKey") = 1
    record1("ConfigValue") = True
    record1("ConfigDescription") = "ErrorLoggingEnabled :التحكم في تفعيل/تعطيل تسجيل الأخطاء في التطبيق في جدول الأخطاء"
    records.Add record1
    
    ' السجل الثانى
    Set record2 = CreateDictionary()
    record2("ConfigKey") = 2
    record2("ConfigValue") = True
    record2("ConfigDescription") = "ShowErrorMessages : التحكم في تفعيل/تعطيل عرض رسائل الخطأ للمستخدم"
    records.Add record2
    
    ' السجل الثالث
    Set record3 = CreateDictionary()
    record3("ConfigKey") = 3
    record3("ConfigValue") = True
    record3("ConfigDescription") = "DebugMode : التحكم في تفعيل/تعطيل وضع التصحيح لتتبع الأخطاء بشكل مفصل في النافذة الفورية"
    records.Add record3

    ' تحديد الحقل/الحقول  - الفريد/الفريدة والتى تمنع عملية تكرار البيانات بإضافة سجلات
    uniqueFields = "ConfigKey"

    ' إنشاء أو تعديل الجدول وإدخال البيانات
    CreateOrModifyTableAndInsertData tblName, Fields, records, uniqueFields, True
End Sub

الغرض منها : 
✔ انشاء الجداول الاجبارية والحقول اللازمة وملئ البيانات 

 

-------------------------------------------------------------
- وحدة نمطية عامة رئيسية باسم basErrorHandler
الاكواد بداخلها 

Option Compare Database
Option Explicit

Public ProcedureName As String

'### إعدادات التكوين (يمكن إدارتها عبر جدول tblErrorSettings) ###
Private Enum ConfigKey
    ErrorLoggingEnabled = 1
    ShowErrorMessages = 2
    DebugMode = 3
    ErrorLogTable = 4
End Enum

'### الهيكل الأساسي لتسجيل الأخطاء ###
Private Type ErrorInfo
    Source As String
    Number As Long
    Description As String
    User As String
    CallExecutionTrace As String
    recordData As String
End Type

' متغير عام لتخزين سلسلة الاستدعاءات
Public gCallExecutionTrace As Collection

' ثابت خاص لتخزين اسم جدول تسجيل الأخطاء
Private Const TableNameErrorLog As String = "tblErrorLog"

' ثابت خاص لتخزين اسم جدول إعدادات الأخطاء
Private Const TableNameErrorSettings As String = "tblErrorSettings"

'==============================================================================
' الدوال الرئيسية للاستخدام الخارجي
'==============================================================================

' معالجة الخطأ الرئيسية (يمكن استدعاؤها من أي مكان)
Public Sub HandleError(SourceProc As String, Optional ShowMessage As Boolean = True, Optional AdditionalInfo As String = "")
    Dim errInfo As ErrorInfo
    Dim errNum As Long, errDesc As String

    ' حفظ تفاصيل الخطأ قبل أي عمليات أخرى
    errNum = Err.Number
    errDesc = Err.Description

    On Error GoTo ErrorHandlerFailure

    With errInfo
        .Source = SourceProc
        .Number = errNum
        .Description = errDesc
        .User = Environ("USERNAME")
        .CallExecutionTrace = GetCallExecutionTrace()
        .recordData = AdditionalInfo
    End With
    
        InitializeErrorSettingsTable
        InitializeTableErrorLog
       
    ' تسجيل الخطأ إذا كان التسجيل مفعلاً
    If GetConfig(ErrorLoggingEnabled, True) Then
        LogError errInfo
    End If

    ' عرض رسالة الخطأ إذا كان مسموحاً
    If ShowMessage And GetConfig(ShowErrorMessages, True) Then
        ShowErrorMessage errInfo
    End If

    ' تصحيح الأخطاء إذا كان وضع التصحيح مفعلاً
    If GetConfig(DebugMode, False) Then
        DebugPrintError errInfo
    End If

    Exit Sub

ErrorHandlerFailure:
    ' Fallback إذا فشل معالج الخطأ نفسه
    MsgBox "Critical failure in error handler: " & Err.Description, vbCritical
End Sub

'==============================================================================
' الدوال الداخلية
'==============================================================================

' تسجيل الخطأ في قاعدة البيانات
Private Sub LogError(errInfo As ErrorInfo)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    On Error GoTo LogErrorFailed
    
    Set db = CurrentDb()
    Set rs = db.OpenRecordset(GetConfig(ErrorLogTable, TableNameErrorLog), dbOpenTable, dbAppendOnly)


    With rs
        .AddNew
            !ErrorDate = Now()
            !Source = Left$(errInfo.Source, 255)
            !ErrorNumber = errInfo.Number
            !ErrorDescription = Left$(errInfo.Description, 255)
            !UserName = Left$(errInfo.User, 50)
            !CallExecutionTrace = Left$(errInfo.CallExecutionTrace, 1000)
            !AdditionalInfo = Left$(errInfo.recordData, 255)
        .Update
    End With

Cleanup:
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Sub

LogErrorFailed:
    ' Fallback: تسجيل في ملف نصي إذا فشل التسجيل في قاعدة البيانات
    LogToTextFile "ErrorLog_" & Format(Now(), "yyyymmdd") & ".log", errInfo
    Resume Cleanup
End Sub

' عرض رسالة خطأ مخصصة للمستخدم
Private Sub ShowErrorMessage(errInfo As ErrorInfo)
    Dim msg As String
    msg = GetErrorMessage(errInfo.Number) & vbCrLf & _
          "Details: " & errInfo.Description & vbCrLf & _
          "Contact: Technical Support"

    MsgBox msg, vbExclamation, "Error " & errInfo.Number
End Sub

' طباعة تفاصيل الخطأ للنافذة المباشرة (لأغراض التصحيح)
Private Sub DebugPrintError(errInfo As ErrorInfo)
    Debug.Print "=== ERROR DEBUG ==="
    Debug.Print "Time: " & Now()
    Debug.Print "Source: " & errInfo.Source
    Debug.Print "Error " & errInfo.Number & ": " & errInfo.Description
    Debug.Print "User: " & errInfo.User
    Debug.Print "Call ExecutionTrace: " & errInfo.CallExecutionTrace
    Debug.Print "Additional Info: " & errInfo.recordData
    Debug.Print "==================="
End Sub

'==============================================================================
' دوال مساعدة
'==============================================================================

' الحصول على إعدادات النظام من جدول التكوين
Private Function GetConfig(key As ConfigKey, defaultValue As Variant) As Variant
    
    Static configCache As Collection
    Dim rs As DAO.Recordset
    Dim sql As String

    If configCache Is Nothing Then
        Set configCache = New Collection
    End If

    On Error Resume Next
    GetConfig = configCache(CStr(key))
    If Err.Number = 0 Then Exit Function

    sql = "SELECT ConfigValue FROM " & TableNameErrorSettings & " WHERE ConfigKey = " & key
    Set rs = CurrentDb.OpenRecordset(sql)

    If Not rs.EOF Then
        GetConfig = rs!ConfigValue
    Else
        GetConfig = defaultValue
    End If

    configCache.Add GetConfig, CStr(key)
    rs.Close
    Set rs = Nothing
End Function

' الحصول على رسالة خطأ مخصصة
Private Function GetErrorMessage(ErrorNumber As Long) As String
    Select Case ErrorNumber
        Case 3021: GetErrorMessage = "No records found. Please check your data."
        Case 3061: GetErrorMessage = "Missing parameter in query."
        Case 7874: GetErrorMessage = "Invalid file format."
        Case Else: GetErrorMessage = "An unexpected error occurred."
    End Select
End Function


'==============================================================================
' دوال إدارة سلسلة الاستدعاءات/الإجراءات التي تم تنفيذها حتى حدوث الخطأ
' ExecutionTrace
'==============================================================================
Public Sub LogCallExecutionTrace(ProcName As String)
    If gCallExecutionTrace Is Nothing Then Set gCallExecutionTrace = New Collection
    gCallExecutionTrace.Add ProcName
End Sub


Public Sub RemoveFromCallExecutionTrace(ProcName As String)
    If gCallExecutionTrace Is Nothing Then Exit Sub
    If gCallExecutionTrace.count = 0 Then Exit Sub
    
    ' البحث عن آخر تكرار للاسم وإزالته
    Dim i As Integer
    For i = gCallExecutionTrace.count To 1 Step -1
        If gCallExecutionTrace(i) = ProcName Then
            gCallExecutionTrace.Remove i
            Exit For
        End If
    Next i
End Sub

Private Function GetCallExecutionTrace() As String
    Dim i As Integer
    Dim ExecutionTrace As String

    If gCallExecutionTrace Is Nothing Or gCallExecutionTrace.count = 0 Then
        GetCallExecutionTrace = "Call ExecutionTrace Empty"
        Exit Function
    End If

    For i = 1 To gCallExecutionTrace.count
        ExecutionTrace = ExecutionTrace & " > " & gCallExecutionTrace(i)
    Next i

    If Len(ExecutionTrace) > 0 Then
        ExecutionTrace = Mid(ExecutionTrace, 4)
    End If

    GetCallExecutionTrace = ExecutionTrace
End Function

' تسجيل الخطأ في ملف نصي كحل بديل
Private Sub LogToTextFile(FileName As String, errInfo As ErrorInfo)
    Dim fnum As Integer
    fnum = FreeFile()

    Open CurrentProject.Path & "\" & FileName For Append As #fnum
    Print #fnum, "[" & Now() & "] Error " & errInfo.Number & " in " & errInfo.Source
    Print #fnum, "User: " & errInfo.User
    Print #fnum, "Description: " & errInfo.Description
    Print #fnum, "----------------------------------------"
    Close #fnum
End Sub

الغرض والفائدة :

✔ إدارة الأخطاء بطريقة مركزيه منظمة وفعالة
إدارة الأخطاء بشكل موحد: يوفر الكود آلية مركزية للتعامل مع الأخطاء في كافة أجزاء التطبيق

✔ إمكانية تتبع الأخطاء وتخزين تفاصيلها في قاعدة البيانات أو في ملف نصي
التسجيل التلقائي للأخطاء: يقوم بتخزين الأخطاء مع تفاصيلها في قاعدة البيانات مما يسهل تتبعها وتحليلها لاحقًا

✔ تقديم رسائل مخصصة للمستخدم
تخصيص الرسائل: يتيح عرض رسائل خطأ مخصصة للمستخدم مع معلومات إضافية حول الأخطاء التي حدثت

✔ التصحيح والتتبع (Debugging)
 يسمح بتسجيل معلومات التصحيح مثل سلسلة الاستدعاءات (Call Stack) واستخدام أوضاع تصحيح الأخطاء مما يسهل اكتشاف مصدر المشكلة
يساعد المطورين على فهم تفاصيل الخطأ بسرعة بفضل تتبع سلسلة الاستدعاءات بحيث يكون من السهل تحديد أي إجراء أو وظيفة تسببت في الخطأ

✔ المرونة في إدارة التحكم في الإعدادت 
يمكن تخصيص إعدادات الكود مثل تمكين أو تعطيل التسجيل للأخطأء فى الجدول - تمكين أو تعطيل عرض الرسائل - تمكين أو تعطيل وضع التصحيح عبر جدول الإعدادات مما يجعل الحل مرنًا وقابلًا للتكيف دون الحاجة لتغيير الكود نفسه حسب الرغبة✔

✔ وظائف مساعدة
تتضمن الوظائف المساعدة مثل GetConfig التي تسترجع إعدادات النظام من الجدول: tblErrorSettings
و كذلك LogCallExecutionTrace التي تسجل تفاصيل الإجراءات أو الوظائف التي تم استدعاؤها
وكذلك  LogToTextFile لتسجيل الأخطاء في ملف نصي إذا فشل التسجيل في جدول : tblErrorLog 


-------------------------------------------------------------
- وحدة نمطية عامة ثانوية باسم basErrorHandlerTest
   ----   هذه الوحدة النمطية فقط للتجربة ولتوضيح طريقة استخدام الاجراء المركزى الموحد فى تتبع الخطأ يمكن حذفها 
الاكواد بداخلها  والتى يمكن تشغيلها من خلا F5   أو Run  للتجربـــة

'==============================================================================
' مثال مفرد لتجربة الخطأ
'==============================================================================
Public Sub TestProcedure()
    On Error GoTo ErrorHandler
    ProcedureName = "TestProcedure"
    LogCallExecutionTrace ProcedureName
    
    Dim x As Integer
    x = 1 / 0 ' خطأ
    
Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub

ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable x=" & x
    Resume Cleanup
End Sub

Public Sub TestOpenForm()
    On Error GoTo ErrorHandler
    ProcedureName = "TestOpenForm"
    LogCallExecutionTrace ProcedureName
    
    Dim strFormName As String
    strFormName = "Moh3sam"
    DoCmd.OpenForm strFormName, acNormal   ' خطأ لا يوجد نموذج أصلا بهذا الاسم
    
Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub

ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable strFormName=" & strFormName
    Resume Cleanup
End Sub




'==============================================================================
' مثال لعدة إجراءات مترابطه لتجربة تتبع مكان حدوث الخطأ تحديدا
' ExecutionTrace
'==============================================================================
Public Sub StartProcess()
    On Error GoTo ErrorHandler
    ProcedureName = "StartProcess"
    LogCallExecutionTrace ProcedureName

    ProcessNumber01

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber01()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber01"
    LogCallExecutionTrace ProcedureName

    ProcessNumber02

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber02()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber02"
    LogCallExecutionTrace ProcedureName

    ProcessNumber03

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName
    Resume Cleanup
End Sub

Private Sub ProcessNumber03()
    On Error GoTo ErrorHandler
    ProcedureName = "ProcessNumber03"
    LogCallExecutionTrace ProcedureName

    ' خطأ القسمة على صفر
    Dim x As Integer
    x = 1 / 0

Cleanup:
    RemoveFromCallExecutionTrace ProcedureName
    Exit Sub
    
ErrorHandler:
    HandleError ProcedureName, AdditionalInfo:="Variable x=" & x
    Resume Cleanup
End Sub

أمثالة تطبيقية :
✔ مثال مفرد :  TestProcedure خطأ عند القسمة على 0
✔ مثال مفرد :  TestOpenForm خطأ عند محاولة فتح نموذج غير موجود 

✔ مثال معقد يعتمد على عدة وظائف لتجربة التتبع : StartProcess

وهنا تكمن الفائدة عند تشغيل أى إجراء أو مثال من أمثلة الخطأ السابقة
-  إعداد الجداول اللازمة والاعدادت بشكل الى واعادتها
- ظهور الرسائل المخصصة لعرض الأخطاء بشكل موحد
- تسجيل الأخطاء داخل الجدول 

-------------------------------
تسهيلا على الجميع
- تم اضافة نموج للتجربة

-------------------------------
- عند فتح القاعدة للمرة الاولى لن تجدوا بها اى جداول
- بمجرد فتح النموذج والضغط على اى من أزرار تجربة الأخطاء سوف يتم إنشاء الجداول والبيانات الخاصة بالاعدادات
- يمكنكم تجربة العبث فى جدول الاعدادت " tblErrorSettings " بتفيير البيانات او حذف احد الحقول أو الجدول نفسه وإعادة التجربة فلن يأثر العبث هذا سلبا على الاعدادت وعمل الجراءات وهذه هى الفائدة من الشق الاول فى الموضوع وهو انشاء الجداول والحقول والبيانات الهامة قسرا 

واخيــــرا المرفق 
أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع 

 

 

دالة مركزية للتعامل مع الأخطاء.zip

[Foksh]

عمل جميل جداً ، وجزاك الله كل خير على مجهودك ..

وتقبل الله طاعاتكم وصيامكم وقيامكم ،، وهنأكم بإفطاركم بهذا الشهر الفضيل ..

 

لي مداخلة بسيطة وهي أن معظم ( 90% ) من مصممي البرامج يتوجهون الى ان تكون الرسائل باللغة العربية ؛

على الأقل ليسهل فهمها للمستخدم وللوصول الى حل المشكلة التي ظهرت له  .

هل يمكن تنفيذ الفكرة ???