البحث في الموقع

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات أقدم اليكم هدية قيمة بكل ما تحمل الكلمة من معنى فى هذا الموضوع من أفكار وأكواد وفوائد هامة لا غنى عنها مطلقا ذات مرة شاركت بكتابة موضوع بخصوص انشاء الجداول واضافة الحقول وخصائصها برمجيا وهذا هو الموضوع واستكمالا لما تم طرحه فى هذا الموضوع السابق الاشارة اليه تعديل وتطوير بعض الاكواد والافكار لاضفاء مرونة واحترافيه وكفائه اكبر الفائده : امكانية عمل الجداول الاساسية بشكل ديناميكى من خلال الكود دون أدنى تدخل من المستخدم الغرض : سهول ومرونة وحفاظا على البيانات والاعدادت الاساسية للتطبيق طيب علشان سامع واحد هناك بيقول ايه يعم ده دا عمل الجدول اسهل واسرع من وجع الدماغ ده هو كلامه صح ... عارف ولكــــن لتوضيح المميزات والآفكار دعونا نمضى فى هذا الموضوع وهذه احد الفوائد العظيمة و الهامة على سبيل المثال فقط وليس الحصر الفكرة كالاتى عمل دالة مركزية للاخطاء داخل الأكواد الفوائد العظيمه من ورائها مرونة فائقة : ✔ إنشاء جداول بشكل ديناميكى لحفظ وتتبع ارقام و وصف و أماكن الأخطاء داخل الإجراءات و زوايا التطبيق المختلفة ..... ✔ إنشاء جداول بشكل ديناميكى للتحكم فى إعدادت التعامل مع الدالة المركزية ✔ إعادة البيانات الاعدادت داخل الجدول اذا تم العبث بها " قسراً " ✔ إعدة الحقول والبيانات اذا تم حذفها" قسراً " ✔ إعادة إنشاء الجداول بشكل ديناميكى مرة أخرى أخرى أذا تم حذفها " قسراً " لنمضى قدما بع هذه المقدمة - وحدة نمطية عامة رئيسية باسم : 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