ابو جودي

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

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات ذات مرة شاركت فى موضوع بخصوص فصل الرقم القومى وهذا هو الموضوع ولكن بصراحه انا معقد بطبعى ولا اهوى الحلول المعتادة والتى تستدعها اعدادها بشكل خاص فى كل مره ولذلك كتبت اجراء ذكي هههههههههه محدش يضحك 😡 شايفكم يوفر العديد من العناء والاستعلامات ووجع الراس ده غير المرونه والــ ...... ما تيجوا نشوف أحسن اولا : وحدة نمطيه عامة باسم : basDistributeNumeric الاكواد داخل الوحدة النمطيه هى : ' إجراء لفحص ما إذا كان النص يحتوي على أرقام فقط Function IsNumericOnly(ByVal InputString As String) As Boolean Dim i As Integer Dim char As String ' التحقق من أن السلسلة ليست فارغة If Len(InputString) = 0 Then IsNumericOnly = False Exit Function End If ' التحقق من أن كل حرف هو رقم فقط For i = 1 To Len(InputString) char = Mid(InputString, i, 1) If Not (char >= "0" And char <= "9") Then IsNumericOnly = False Exit Function End If Next i ' إذا كانت جميع الأحرف أرقام، ترجع True IsNumericOnly = True End Function الغرض : التأكد من ان القيمه التى سوف يتم تمريرها هى أرقام ثم الإجراء الرئيسي : لفصل الأرقام ' إجراء لفصل و توزيع القيم الرقمية اما فى متغير او عنصر تحكم مثل مربع نص Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, Optional MaxFields As Integer = 14, Optional ControlPrefix As String = "txt") Dim Index As Integer Dim ControlItem As Control Dim TextBoxCollection As Object ' Dictionary لتخزين مربعات النص Dim TargetTextBox As Control ' لتعريف كل مربع نص عند التكرار Dim NumericString As String Dim DictKey As Variant ' لتجنب مشاكل الفهارس عند التعامل مع Dictionary ' التحقق من نوع الإدخال ومعالجته If TypeName(InputValue) = "TextBox" Then If IsNull(InputValue.Value) Or Not IsNumericOnly(InputValue.Value) Then MsgBox "الإدخال غير صالح، يرجى إدخال أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue.Value ElseIf VarType(InputValue) = vbString Or VarType(InputValue) = vbVariant Then If Not IsNumericOnly(InputValue) Then MsgBox "الإدخال يجب أن يحتوي على أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue Else MsgBox "نوع الإدخال غير مدعوم، يرجى إدخال مربع نص أو قيمة رقمية نصية!", vbCritical, "خطأ" Exit Sub End If ' إنشاء قاموس لتخزين مربعات النص ذات البادئة المحددة فقط Set TextBoxCollection = CreateObject("Scripting.Dictionary") ' البحث عن مربعات النص المناسبة داخل النموذج أو التقرير If Not TargetObject Is Nothing Then For Each ControlItem In TargetObject.Controls ' التأكد من أن العنصر هو مربع نص ويمتلك البادئة المحددة If TypeName(ControlItem) = "TextBox" And Left(ControlItem.Name, Len(ControlPrefix)) = ControlPrefix Then Index = Val(Mid(ControlItem.Name, Len(ControlPrefix) + 1)) ' استخراج الرقم من اسم مربع النص If Index >= 1 And Index <= MaxFields Then TextBoxCollection.Add Index, ControlItem End If End If Next ControlItem End If ' مسح محتوى مربعات النص إذا كان هناك مربعات متاحة If TextBoxCollection.Count > 0 Then For Each DictKey In TextBoxCollection.Keys TextBoxCollection(DictKey).Value = "" ' مسح القيم Next DictKey End If ' التحقق من توفر عدد كافٍ من مربعات النص If TextBoxCollection.Count > 0 And TextBoxCollection.Count < Len(NumericString) Then MsgBox "عدد مربعات النص غير كافٍ لعرض كافة الأرقام!", vbExclamation, "خطأ" Exit Sub End If ' توزيع الأرقام على مربعات النص For Index = 1 To Len(NumericString) If Index > MaxFields Then Exit For If TextBoxCollection.Exists(Index) Then Set TargetTextBox = TextBoxCollection(Index) TargetTextBox.Value = Mid(NumericString, Index, 1) Else Call PrintDigitInfo(Index, ControlPrefix, NumericString) End If Next Index ' تنظيف المتغيرات Set TextBoxCollection = Nothing Set TargetTextBox = Nothing End Sub الغرض : الفصل والتوزيع تم كتابة الإجراء السابق بشكل احترافى ومرن ليمكن استدعاءه بتمرير معاملات اليه بكل مرونه الفوائد : ✔ مرونة فائقة : يمكن استدعاء الإجراء دون الحاجة إلى تمرير Target Object إذا لم يكن مطلوبا ✔ دعم إستخدام القيم بشكل مباشر : يمكن استخدامه فقط لمعالجة قيمة رقمية وطباعة النتيجة بدلا من الحاجة إلى نموذج أو تقرير ✔ دعم الاستخدام الأمثل لتعبئة القيم : يمكن استخدامه لمعالجة القيم أو تعبئة مربعات النص حسب الحاجة ✔ الاستدعاء مع نموذج أو تقرير >>--> تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام " يعنى مثلا مع الرقم القومى سوف استخدم عدد 14 مربع يبدأ بالبادئة : txtNatId ثم الرقم من 1 الى الرقم 14 " فى الاستدعاء التالى مثلا تحصل على فصل وتوزيع 14 أرقام Call BindTextBoxes(Me, "txtIns", 14, "txtNatId " أو ممكن بهذا الشكل فى هذه الحاله يتم استخدام الرقم الاختيارى المفضل ضمن الكود وهو 14 Call BindTextBoxes(Me, "txtIns", , "txtNatId " * وماذا لو كان هناك اكثر من رقم مثلما هو موجود فى الموضوع المشار إليه مثل الرقم التأمينى , كود المنشأه ونريد فصلهم بنفس الآليه وهذا هو ما دفعنى الى التفكير فى كتابة هذه الإجراءات الذكيه والتى يمكنها التعامل مباشرة بكل سهولة مع اى سلسلة رقميه مهما كان طولها أو اختلفت طيب لاعادة الاستدعاء مع امثلة أخري مثل الرقم التآمينى مثلا تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه سوف نستخدم مثلا 10 أرقام ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام مثلا مع الرقم التآمينى سوف استخدم عدد 10 مربع يبدأ بالبادئة : txtIns ثم الرقم من 1 الى الرقم 10" Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") وهكذا حسب الحاجة وحسب الرغبه * اذا أردانا التجربة للطباعة داخل النافذة الفورية على سبيل التجربة ' لتجربة طباعة النتيجة مباشرة في النافذة الفورية Private Sub PrintDigitInfo(Index As Integer, ControlPrefix As String, NumericString As String) Debug.Print "Digit Index " & Format(Index, "00") & " is : >>-> " & ControlPrefix & " " & Mid(NumericString, Index, 1) End Sub ونكتب مباشرة فى النافذة الفورية على سبيل المثال : DistributeNumericInput , "9876543210",5,"" سوف نحصل منها على النتيجة التاليه لفصل الارقام الخمسة الاولى Digit Index 01 is : >>-> 9 Digit Index 02 is : >>-> 8 Digit Index 03 is : >>-> 7 Digit Index 04 is : >>-> 6 Digit Index 05 is : >>-> 5 - طيب لنفترض اناا نريد تنفيذ عملية الفصل والتوزيع فى نموذج مستمر : برضو كتبت لكم إجراء ذكى لعمل استعلام ديناميكى الكود فى الوحدة النمطيه ' إجراء لإنشاء استعلام ديناميكي بناءً على الحقول المدخلة Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String Dim sqlQuery As String Dim i As Integer Dim fieldName As String Dim maxDigits As Integer Dim fieldPrefix As String Dim fieldInfo As Variant ' بدء بناء جملة SQL sqlQuery = "SELECT " & tableName & ".*, " ' معالجة كل حقل مطلوب مع عدد الأرقام والبادئة الخاصة به For Each fieldInfo In RequiredFieldsDistribute fieldName = fieldInfo(0) ' اسم الحقل maxDigits = fieldInfo(1) ' عدد الأرقام المطلوب توزيعها fieldPrefix = fieldInfo(2) ' البادئة المخصصة للحقول ' إنشاء الحقول المحسوبة لكل رقم في الحقل المطلوب مع البادئة For i = 1 To maxDigits sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & i & ", Null, Mid([" & fieldName & "], " & i & ", 1)) AS " & fieldPrefix & i & ", " Next i Next fieldInfo ' إزالة الفاصلة الأخيرة لإكمال الجملة بشكل صحيح sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2) ' إضافة جملة FROM sqlQuery = sqlQuery & " FROM " & tableName & ";" ' إرجاع جملة SQL النهائية GenerateDynamicSQL = sqlQuery End Function الغرض : عمل استعلام ديناميكى بكل سهولة ليكون مصدر بيانات للنموذج المستمر الفوائد : ✔ مرونة فائقة : تمرير اسم الجدول الذى يحتوى على حقل/حقول الأرقام المراد فصلها وتوزيعها ✔ مرونة فائقة : تمرير اسم (الحقل/حقول) للأرقام وذلك من خلال مصفوفة وفق الإجراء السابق الكود فى الوحدة النمطيه : ' إجراء للتحقق من وجود عنصر التحكم في النموذج Private Function ControlExists(frm As Form, ctrlName As String) As Boolean On Error Resume Next ControlExists = Not (frm.Controls(ctrlName) Is Nothing) On Error GoTo 0 End Function ' إجراء لربط مربعات النص بحقول البيانات تلقائيًا Sub BindTextBoxes(frm As Form, prefix As String, maxDigits As Integer) Dim i As Integer Dim ctrlName As String ' تعيين الحقول بناءً على العدد الصحيح لكل نوع For i = 1 To maxDigits ctrlName = prefix & i ' التحقق من وجود العنصر قبل تعيين ControlSource If ControlExists(frm, ctrlName) Then frm.Controls(ctrlName).ControlSource = ctrlName ' الحقل مرتبط مباشرة بالاستعلام End If Next i End Sub الفوائد : التأكد من وجود عناصر التحكم اللازمة أجراء لربط الحقول مع العناصر الخاصة بناء على الفصل وذلك لعملية التوزيع وبعد ذلك نقوم بعمل النموذج المستمر ونضع فيه العناصر اللازمة مع ضبط التسميات وفق الكود التى ونستدعى الإجراء السابق فى حدث الفتح للنموذج المستمر لتعين مصدر بيانات النموذج وفق الاستعلام الديناميكى داخل الإجراء الكود فى النموذج المستمر Private Sub Form_Open(Cancel As Integer) ' تعريف متغير لتخزين جملة SQL Dim sqlStatement As String ' إنشاء استعلام SQL ديناميكي لجلب البيانات المطلوبة مع توزيع الأرقام في الحقول sqlStatement = GenerateDynamicSQL("tblEmployees", _ Array("NationalID", 14, "txtNatId"), _ Array("InsuranceID", 10, "txtIns"), _ Array("OrganizationID", 10, "txtOrg")) ' تعيين جملة SQL كمصدر بيانات للنموذج Me.RecordSource = sqlStatement ' إعادة تحميل البيانات بعد تحديث مصدر السجلات Me.Requery End Sub - طبعا عند تغير الاسماء داخل الكود لابد من مطابقتها بالاسماء للعناصر داخل النموذج أو العكس الخطوة التاليه وهى توزيع الارقام التى تم فصلها على مربعات النص الغير منضمه اعتمادا على مصدر البيانات الذى تم انشائه بشكل آالى عند فتح النموذج ويتم ذلك من خلال الستدعاء التالى فى النموذج الكود داخل النموذج فى الحدث الحالى Private Sub Form_Current() ' ربط مربعات النصوص ببيانات الهوية القومية (14 خانة) Call BindTextBoxes(Me, "txtNatId", 14) ' ربط مربعات النصوص ببيانات الرقم التأميني (10 خانات) Call BindTextBoxes(Me, "txtIns", 10) ' ربط مربعات النصوص ببيانات كود المنشأة (10 خانات) Call BindTextBoxes(Me, "txtOrg", 10) End Sub بذلك نضمن فصل وتوزيع الارقام بشكل آلى * طيب الان لو أردنا عمل الفصل والتوزيع داخل تقرير : فى تصميم التقرير نقوم بالاعلان عن المتغيرات التاليه ' تعريف متغيرات لتخزين القيم النصية للأرقام Dim lngNationalID As String Dim lngInsuranceID As String Dim lngOrganizationID As String نقوم بعد ذلك باستدعاء إجراء الفصل والتوزيع حسب مكان مربعات النص اما فى منطقة الرأس أو التفصيل أو ذيل النموذج وفى حدث التنسيق لكل منطقة حسب تواجد المربعات الغير منضمه بها باستدعاء الأجراء بالشكل المباشر الكود داخل التقرير : Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم القومي If Not IsNull(Me!txtNationalID) Then lngNationalID = Trim(Me!txtNationalID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngNationalID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم التأميني If Not IsNull(Me!txtInsuranceID) Then lngInsuranceID = Trim(Me!txtInsuranceID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngInsuranceID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم القومي Call DistributeNumericInput(Me, lngNationalID, 14, "txtNatId") ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم التأميني Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") End Sub Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بكود المنشأة If Not IsNull(Me!txtOrganizationID) Then lngOrganizationID = Trim(Me!txtOrganizationID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngOrganizationID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بكود المنشأة Call DistributeNumericInput(Me, lngOrganizationID, 10, "txtOrg") End Sub --------------------------------------------- صورة توضيحيه من نموذج مفرد --------------------------------------------- صورة توضيحية من نموذج مستمر --------------------------------------------- صورة توضيحية من تقرير واخيــــرا المرفق أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع فصل و توزيع ارقام الرقم القومى.zip

اتفضل 1.accdb

جزانا الله واياكم خير الجزاء لازم سؤال لولبى ... ليه الإحراج ده شوف يا سيدى انا لم استخدم المكتبه المدمجه باضافتها كـ References فى القاعده بناء على ذلك لم اقم بتعريف المتغيرات بهذا الشكل : Dim db As Databaseوالذى يعتمد على المكتبه السابقة فى الاصدارات القديمه بل قمت بتعريف المتغيرات بالشكل التالى : Dim db As DAO.Database وهذا يقلل من احتمالية الأخطاء إذا كانت المكتبة مفقودة اعرف ان الاصدرات الحديثه بدأ من 2013 وما بعده تستخدم DAO المدمج مع محرك ACE (Access Connectivity Engine) وتستبدل محرك Jet القديم حاولت جاهد وكذلك فى موضوع انشاء هيكل المجلدات ان لا اعتمد على المكتبات الداخليه بشكل صريح حاولت استخدام Late Binding بدلا من استخدام Early Binding حيث لا يتم ربط الكائنات بالمكتبة حتى وقت التشغيل ولكن بصراحة الامر يستوجب التجربه للتأكد

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

والان مع الاصدار الجديد ـــــــــــــــــــــــــــــــــــــــــ اولا الاكواد داخل الوحده النمطيه العامة طبعا افضل كتابه الكود ومشاركته تحسبا لوجود اى مشاكل فى المرفقات او التحميل لنعطى مثلا للوحدة النمطية العامة الاسم : basTablesCreator Option Compare Database Option Explicit ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات Public Enum FieldsTypes 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 ' نوع الحقل: Big Integer (عدد صحيح كبير جدًا، 64 بت) dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات) End Enum ' دالة لإنشاء قاموس جديد عند الحاجة إليه Public Function CreateDictionary() As Object ' إنشاء قاموس جديد باستخدام "Scripting.Dictionary" Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldsTypes, _ Optional fieldSize As Variant, _ Optional fieldFormat As String = "", _ Optional defaultValue As Variant = Null, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "" _ ) ' إنشاء قاموس جديد لتخزين معلومات الحقل Dim fieldDict As Object Set fieldDict = CreateObject("Scripting.Dictionary") ' قاموس لأحجام الحقول الافتراضية بناءً على نوع الحقل Dim defaultFieldSizes As Object Set defaultFieldSizes = CreateObject("Scripting.Dictionary") ' قاموس للتنسيقات الافتراضية بناءً على نوع الحقل Dim defaultFormats As Object Set defaultFormats = CreateObject("Scripting.Dictionary") ' إضافة الأحجام الافتراضية لكل نوع حقل With defaultFieldSizes .Add dbBoolean, 0 ' لا يحتاج Boolean إلى حجم .Add dbByte, 0 ' Byte لا يحتاج إلى حجم .Add dbInteger, 0 ' Integer لا يحتاج إلى حجم .Add dbLong, 0 ' Long لا يحتاج إلى حجم .Add dbCurrency, 0 ' Currency لا يحتاج إلى حجم .Add dbSingle, 0 ' Single لا يحتاج إلى حجم .Add dbDouble, 0 ' Double لا يحتاج إلى حجم .Add dbDate, 0 ' Date/Time لا يحتاج إلى حجم .Add dbText, 255 ' Text: الحجم الافتراضي هو 255 .Add dbMemo, 0 ' Memo لا يحتاج إلى حجم .Add dbBigInt, 0 ' BigInt لا يحتاج إلى حجم .Add dbVarBinary, 0 ' VarBinary لا يحتاج إلى حجم .Add dbNumeric, 0 ' Numeric لا يحتاج إلى حجم .Add dbMultipleChoice, 0 ' Multiple Choice لا يحتاج إلى حجم .Add dbAutoNumber, 0 ' AutoNumber لا يحتاج إلى حجم .Add dbAttachment, 0 ' Attachment لا يحتاج إلى حجم End With ' إضافة التنسيقات الافتراضية لكل نوع حقل With defaultFormats .Add dbBoolean, "Yes/No" ' تنسيق Boolean الافتراضي .Add dbByte, "" ' لا يوجد تنسيق افتراضي لـ Byte .Add dbInteger, "" ' لا يوجد تنسيق افتراضي لـ Integer .Add dbLong, "" ' لا يوجد تنسيق افتراضي لـ Long .Add dbCurrency, "Currency" ' تنسيق Currency الافتراضي .Add dbSingle, "Standard" ' تنسيق Single الافتراضي .Add dbDouble, "Standard" ' تنسيق Double الافتراضي .Add dbDate, "Short Date" ' تنسيق Date/Time الافتراضي .Add dbText, "" ' لا يوجد تنسيق افتراضي لـ Text .Add dbMemo, "" ' لا يوجد تنسيق افتراضي لـ Memo .Add dbBigInt, "" ' لا يوجد تنسيق افتراضي لـ BigInt .Add dbVarBinary, "" ' لا يوجد تنسيق افتراضي لـ VarBinary .Add dbNumeric, "" ' لا يوجد تنسيق افتراضي لـ Numeric .Add dbMultipleChoice, "" ' لا يوجد تنسيق افتراضي لـ Multiple Choice .Add dbAutoNumber, "" ' لا يوجد تنسيق افتراضي لـ AutoNumber .Add dbAttachment, "" ' لا يوجد تنسيق افتراضي لـ Attachment End With ' التحقق من إذا لم يتم تحديد fieldSize، نستخدم القيمة الافتراضية من القاموس If IsMissing(fieldSize) Or isEmpty(fieldSize) Then If defaultFieldSizes.exists(fieldType) Then fieldSize = defaultFieldSizes(fieldType) Else fieldSize = 0 ' إذا لم يكن النوع معروفًا، نستخدم 0 كقيمة افتراضية End If End If ' التحقق من إذا لم يتم تحديد fieldFormat، نستخدم القيمة الافتراضية من القاموس If fieldFormat = "" Then If defaultFormats.exists(fieldType) Then fieldFormat = defaultFormats(fieldType) End If End If ' إضافة الحقول إلى القاموس مع طباعة القيم في النافذة الفورية fieldDict("Name") = fieldName fieldDict("Type") = fieldType fieldDict("Size") = fieldSize fieldDict("Caption") = fieldCaption fieldDict("Description") = fieldDescription fieldDict("DefaultValue") = defaultValue fieldDict("Format") = fieldFormat ' التحقق من إذا كان القاموس فارغًا، وإذا كان كذلك يتم تهيئته باستخدام قاموس جديد If Fields Is Nothing Then Set Fields = CreateObject("Scripting.Dictionary") ' إضافة القاموس الخاص بالحقل إلى القاموس العام باستخدام اسم الحقل كمفتاح 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() ' إنشاء كائن 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("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size")) Else ' إذا كان نوع الحقل هو dbAutoNumber، يتم إنشاء حقل من النوع dbLong مع تعيينه كحقل تلقائي 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 Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf 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 ' البحث عن أول حقل من النوع AutoNumber في القاموس For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not IsFieldExist(tdf, fieldDict("Name")) Then ' إذا لم يكن الحقل من نوع AutoNumber، يتم إضافته بالخصائص المحددة If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else ' إذا كان نوع الحقل هو AutoNumber، يتم إنشاء حقل من النوع dbLong مع تعيينه كحقل تلقائي Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld End If Next key End Sub ' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول 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 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 ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية fld.defaultValue = "" End If End If End If Next key End Sub ' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر Public Function CloseTableIfNecessary(tableName As String) As Boolean Dim db As DAO.Database Set db = CurrentDb ' حاول إغلاق الجدول إذا كان مفتوحًا On Error Resume Next ' إغلاق الجدول إذا كان مفتوحًا DoCmd.Close acTable, tableName If Err.Number = 0 Then ' إذا تم إغلاق الجدول بنجاح CloseTableIfNecessary = True Else ' إذا فشل في إغلاق الجدول CloseTableIfNecessary = False End If On Error GoTo 0 End Function ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه وإضافة البيانات إذا كانت موجودة Public Sub CreateOrModifyTable(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb() ' إذا لم يكن الجدول موجودًا، نقوم بإنشائه If Not IsTableExist(tableName) Then CreateNewTable tableName, Fields Else ' إذا كان الجدول موجودًا، نقوم بتحديث الحقول فيه Set tdf = db.TableDefs(tableName) EnsureFieldsExist tdf, Fields End If ' إضافة أو تحديث خصائص الحقول SetFieldProperties tableName, Fields ' تحديث نافذة قاعدة البيانات لتظهر التغييرات Application.RefreshDatabaseWindow End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه بالإضافة إلى إضافة البيانات إذا كانت موجودة Public Sub CreateOrModifyTableAndInsertData(tableName As String, _ Fields As Object, _ Optional fieldValues As Object, _ Optional bAddData As Boolean = False) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim rst As DAO.Recordset Dim key As Variant Dim fieldValue As Variant Dim fieldName As String Set db = CurrentDb() ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tableName) Then ' في حال كان الجدول مفتوحًا بواسطة مستخدم آخر، نعرض رسالة تحذير MsgBox "لا يمكن تعديل الجدول لأنه مفتوح بواسطة مستخدم آخر.", vbExclamation Exit Sub End If ' إنشاء الجدول أو تحديثه If Not IsTableExist(tableName) Then CreateNewTable tableName, Fields Else Set tdf = db.TableDefs(tableName) EnsureFieldsExist tdf, Fields End If ' إضافة خصائص الحقول SetFieldProperties tableName, Fields ' إضافة البيانات إذا كانت القيمة للعلم صحيحة If bAddData And Not (fieldValues Is Nothing) Then If fieldValues.Count > 0 Then ' فتح مجموعة السجلات للجدول المحدد Set rst = db.OpenRecordset(tableName, dbOpenDynaset) ' التحقق مما إذا كان الجدول فارغًا Dim isEmpty As Boolean isEmpty = (rst.RecordCount = 0) If isEmpty Then ' إذا كان الجدول فارغًا، نضيف سجل جديد rst.AddNew ' إضافة البيانات من القاموس إلى السجل الجديد For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) rst(fieldName) = fieldValue Next key rst.Update Else ' إذا كان الجدول غير فارغ، نقوم بتحديث السجلات الموجودة rst.MoveFirst For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) ' التحقق من وجود تغيير في قيمة الحقل قبل التحديث If IsNull(rst(fieldName)) Or Nz(rst(fieldName), "") <> fieldValue Then rst.Edit rst(fieldName) = fieldValue rst.Update End If Next key End If rst.Close End If End If ' تحديث نافذة قاعدة البيانات بعد التعديل Application.RefreshDatabaseWindow End Sub الان الوحدة النمطية الثانويه والخاصة باستدعاء الداول اما لانشاء جدول/جداول فارغه بدون بيانات او انشاء جدول/جداول مع الحاق بيانات اساسية لحقل/حقول الجدول/الجداول لنعطى مثلا للوحدة النمطية العامة الاسم : basTablesInitialization ' هذا الإجراء يقوم بتهيئة البيانات الخاصة بالتصميم (إنشاء الجدول وإضافة البيانات) Public Sub InitializeDesignerTableWithData() Dim fieldValues As Object Dim tblName As String tblName = "UsysTblDesignerInformation" ' اسم الجدول الذي يحتوي على معلومات المصمم Set Fields = CreateDictionary() ' إنشاء القاموس لاحتواء الحقول Set fieldValues = CreateDictionary() ' إنشاء القاموس لاحتواء القيم المرتبطة بالحقول ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "حقل :المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, 100, "@[red]", "Officena", "المنصة", "حقل : يحتوى على رابط المنصة" AddFieldToDictionary "FullName", dbText, , , , "الاسم", "حقل : يحتوى على اسم المبرمج" AddFieldToDictionary "Email", dbText, , , , "البريد الإلكتروني", "حقل : يحتوى على البريد الإلكتروني للمبرمج" AddFieldToDictionary "PhoneNumber", dbText, , , , "رقم الهاتف", "حقل : يحتوى على رقم الهاتف للمبرمج" AddFieldToDictionary "DesignSpecialty", dbText, , , , "مجال التخصص", "حقل : يحتوى على مجال التخصص (التخصص الفني أو المهني للمصمم - تصميم واجهات المستخدم (UI) - تصميم تجربة المستخدم (UX) - تطوير البرمجيات الخلفية (Back-End) )" AddFieldToDictionary "PortfolioLink", dbText, , , , "سابقة الأعمال", "حقل : يحتوى على رابط لمعرض سابقة الأعمال للمبرمج - موقع المبومج" AddFieldToDictionary "CreationDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "تاريخ إنشاء السجل", "حقل : يحتوى على تاريخ إنشاء السجل الحالى" ' إضافة القيم الخاصة بكل حقل fieldValues("DesignerPlatform") = "Example Designer Platform™" fieldValues("FullName") = "Example Designer Name" fieldValues("Email") = "example.designer@email.com" fieldValues("PhoneNumber") = "+000 Example Designer Phone Number" fieldValues("DesignSpecialty") = "Example Designer Specialty" fieldValues("PortfolioLink") = "https://example.com/designer-portfolio" fieldValues("CreationDate") = Now ' تعيين تاريخ السجل الحالي ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tblName) Then Exit Sub ' إغلاق الجدول إذا كان مفتوحًا من قبل ' إنشاء الجدول أو تحديثه، بالإضافة إلى إضافة البيانات إذا كانت القيم موجودة CreateOrModifyTableAndInsertData tblName, Fields, fieldValues, True End Sub ' هذا الإجراء يقوم بتهيئة الجدول فقط بدون إضافة البيانات الخاصة بالتصميم Public Sub InitializeDesignerTableStructure() Dim tblName As String tblName = "UsysTblDesignerInformation" ' اسم الجدول الذي يحتوي على معلومات المصمم Set Fields = CreateDictionary() ' إنشاء القاموس لاحتواء الحقول ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "حقل :المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, 100, "@[red]", "Officena", "المنصة", "حقل : يحتوى على رابط المنصة" AddFieldToDictionary "FullName", dbText, , , , "الاسم", "حقل : يحتوى على اسم المبرمج" AddFieldToDictionary "Email", dbText, , , , "البريد الإلكتروني", "حقل : يحتوى على البريد الإلكتروني للمبرمج" AddFieldToDictionary "PhoneNumber", dbText, , , , "رقم الهاتف", "حقل : يحتوى على رقم الهاتف للمبرمج" AddFieldToDictionary "DesignSpecialty", dbText, , , , "مجال التخصص", "حقل : يحتوى على مجال التخصص (التخصص الفني أو المهني للمصمم - تصميم واجهات المستخدم (UI) - تصميم تجربة المستخدم (UX) - تطوير البرمجيات الخلفية (Back-End) )" AddFieldToDictionary "PortfolioLink", dbText, , , , "سابقة الأعمال", "حقل : يحتوى على رابط لمعرض سابقة الأعمال للمبرمج - موقع المبومج" AddFieldToDictionary "CreationDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "تاريخ إنشاء السجل", "حقل : يحتوى على تاريخ إنشاء السجل الحالى" ' التأكد من إغلاق الجدول قبل التعديل If Not CloseTableIfNecessary(tblName) Then Exit Sub ' إغلاق الجدول إذا كان مفتوحًا من قبل ' إنشاء الجدول أو تحديثه فقط بدون إضافة البيانات CreateOrModifyTableAndInsertData tblName, Fields, , False ' لا يتم إضافة بيانات هذه المرة End Sub بشكل عام حنى تتضح الرؤيه بشكل مفصل الفكرة هنا هى كتابة دوال لانشاء الجداول الاساسية للتطبيق والتى لا يريد المبرمج لاى احد العبث بها سواء كان فى : اسم الجدول - اسم الحقل - نوع الحقل :خصائص الحقل ( الحجم - التنسيق - القيمه الافتراضيه - التسميه " عنوان الحقل" - الوصف : الذى يظهر دخل الجدول عند وضع التصميم ) حيث يهدف هذا الكود إلى توفير حل برمجي متكامل لإنشاء جداول قواعد البيانات وتحديثها تلقائيًا بناءً على مواصفات الحقول المحددة في قاموس ديناميكي . مما يتيح الكود للمطورين إدارة هيكل الجدول (Structure) وخصائص الحقول (Properties) مثل الاسم، النوع، الحجم، التنسيق (Format)، القيمة الافتراضية (DefaultValue)، العنوان (Caption)، الوصف (Description)، بطريقة آلية ودقيقة إذا تم تغيير أي خاصية يدويًا (مثل الحجم - التنسيق - القيمه الافتراضيه - العنوان - الوصف )، يتم استعادتها إلى القيم الأصلية المحددة في الكود قصرا بشكل صارم عند تشغيل الدالة مرة أخرى فيضمن الكود أن جميع الجداول والحقول تحتوي على نفس المواصفات والقيم المحددة سلفا وبعيدا عن استدعاء الدوال التى تنشئ جداول مع اضافة البيانات فهناك داله تنئ جداول فقط مع التحكم فى الخصائص كما سلف ذكرها بنفس الاليه بدون ملئ اى بيانات داخل الحقول ليضمن المبرمج دائما عدم مسح الجداول الاساسيه او العبث بها مثال سريع: عمل جدول بيانات المصمم ملئ البيانات استدعاء الدالة عند كل تشغيل يضمن عدم العبث بمسح احد الحقول او الجدول او تعديل اسماء او خصائص او قيم الحقول جداول الاعدادات مثل المسارات الاساسية على سبيل المثال وليس الحصر جداول حمل المرفقات الاساسية التتى يتطلب وجودها بشكل اساسى جداول الصلاحيات للمستخدمين مثلا و و و ......... الخ كل ذلك على سبيل المثال وليس الحصر ملحوظه طبعا يمكن استخدام هذه الافكار كلبنه أولى عند محاولة حماية قاعدة البيانات اخيرا اضع مرفقا بين اياديكم للتجربة والاستمتاع انشاء الجداول الاساسية وملئ البيانات V 3.0.2.accdb

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

السلام عليكم ورحمة الله تعالى وبركاته اولا وقبل كل شئ وليس آخرا التمس من كل اساتذتى العذر فى التأخر فى الرد على حضراتكم لظروف خارجه عن ارادتى استاذى القدير ومعلمى الجليل واخى الحبيب الجميل انتم روعة حياتنا بارك الله لنا فيكم واساله ان لا يحرمنا من جمعكم الطيب ----------------------------------------------- استاذى الجليل و معلمى القدير واخى الحبيب تشتاق لكم الجنان ان شاء الله فانتم روعة حياتنا بخصوص خراب الشغل على المبرمجين ... طبعا لا يرضينى ذلك مطلقا ولم اقصد او اتعمد ذلك ولم اعلم عن ذلك شيئا واسأل الله تعالى ان يستخدمنا فى صلاح امور العباد ولخدمة العباد لوجه رب العباد ان شاء الله واسال الله تعالى ان يبارك لك عباده فى ارزاقهم ويرزقكهم البركة كذلك فى ارزاقهم ان شاء الله ---------------------------------------- أستاذي الجليل ومعلمي القدير ووالدي الحبيب الطيب، أسأل الله تعالى أن يبارك في عمركم ويديمكم فوق رؤوسنا، وأن يرزقكم الخير كله ويرضى عنكم، اللهم آمين. أولًا، جزاكم الله خيرًا على دعواتكم الطيبة يا صاحب القلب النقي، وأسأل الله تعالى أن يرزقكم أجرها وفضلها وبركتها مضاعفًا أضعافًا، اللهم آمين. أما بخصوص البذل والعطاء، فأنتم قدوتنا وعلى دربكم نسير. نحن طلاب العلم نقتدي بكم ونسأل الله تعالى أن يرزقكم أجر من سنّ سنة حسنة، فله أجرها وأجر من يعمل بها من بعده. وبالأصالة عن نفسي، وبالنيابة عن طلاب العلم الذين يتعلمون على أيديكم الطاهرة المباركة، أبشركم أن ذلك هو حصاد زرعكم الطيب. فنسأل الله أن يتقبل من كل أساتذتنا العظماء الذين نتعلم منهم، وأن يجعل ما تعلمناه عنهم صدقة جارية يُكتب لهم به علم ينتفع به. نسأل الله أيضًا أن يُثقل موازينهم بأجر البذل والعطاء الذي غرسوه في قلوب طلابهم، ويجعلهم من أهل السنة الحسنة، اللهم آمين. في الختام، كنت أتمنى الاطلاع على نتائج تجاربكم الكريمة وعلى آرائكم فيما يتعلق بالأفكار وآلية العمل، سواء كان رضا أو نقدًا بنّاء. إن شاء الله، جاري العمل على إعداد نسخة محسّنة تشمل جميع التفاصيل وتوفر تحكمًا أكثر تفصيلًا وعمقًا، حتى يأخذ كل ذي حق حقه. أستاذي الجليل ومعلمي القدير وأخي الحبيب الأستاذ @Foksh أتوجه إليكم بخالص الشكر والتقدير على هذا التحديث، فقد اعتمدت أفكاري الجديدة – بعد توفيق الله عز وجل – على أفكاركم الرائعة التي اقتبستها من أفكاركم فى أحد أعمالكم ، خاصة ما يتعلق بالتحكم في خصائص حجم الحقل. هذا دفعني للتطلع أيضًا إلى إضافة مزيد من التحكم في إعدادات خصائص الحقل للتنسيق بشكل أفضل.

UPDATE [ارقام مسلسله] SET [مسلسل] = IIf( InStr([مسلسل], "/2024") > 0, Left([مسلسل], Len([مسلسل]) - 5) & "/" & Year(Date()), [مسلسل] ) ولكن هذا افضل ليه إذا كان الحقل "مسلسل" يحتوي على أكثر من شريط مائل / في النص فإن : InStr([مسلسل], "/") سوف يعيد موضع أول شريط مائل فقط في هذه الحالة سيتغير الجزء الأيسر ولكن لن يتم استبدال السنة بشكل صحيح إذا كان هناك شرطة مائلة آخري الصح وانت تضع حل مشكله توقع الاخطاء التى قد تصادفها وتسبب خطأ فى حل المشكله

السلام عليكم ورحمة الله تعالى وبركاته استكمالا لسلسلة الافكار المطروحة للنقاش والتى اتمنى ان اجد فيها تفاعلا بالنقاش وابداء الرأى اليوم اقدم لكم التالى الكود يهدف إلى إدارة الحقول والجداول في قاعدة بيانات يتضمن الكود مجموعة من الإجراءات التي تمكن المستخدم من: إنشاء الجداول و الحقول في الجداول وتحديث خصائص الحقول مثل التسمية والوصف ويمكن إضافة البيانات إلى الجداول بشكل اختياري الى الحقول كذلك اذا استدعت الحاجة الى ذلك كما يتيح الكود إضافة الحقول إلى الجداول إذا كانت غير موجودة أو تحديث البيانات داخل الحقول فى الجداول إذا كانت موجودة يتم أيضًا دعم الحقول المتعددة الخيارات (MultipleChoice) من خلال التعداد FieldsTypes يتم استخدام القاموس لتخزين الحقول ومعلوماتها، مما يتيح تنظيم البيانات بشكل مرن يضمن الكود تحديث الجداول وإضافة الحقول والخصائص بشكل ديناميكي، مع إمكانية إضافة البيانات إذا كانت مطلوبة الكود الرئيسي استخدام القواميس Dictionary بدون الحاجة إلى تفعيل مكتبة Microsoft Scripting Runtime حتى لا يتوقف الكود عن العمل فى حال نقل الموديول الى قاعدة اخرى بدون تفعيل المكتبة الموديول الرئيسي : Option Compare Database Option Explicit ' تعريف تعداد لأنواع الحقول Public Enum FieldsTypes dbBoolean = 1 ' نوع الحقل: Boolean (قيمة منطقية: صحيح أو خطأ) dbByte = 2 ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255) dbInteger = 3 ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767) dbLong = 4 ' نوع الحقل: Long (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647) dbCurrency = 5 ' نوع الحقل: Currency (عدد عشري بدقة عالية لاستخداماته المالية) dbSingle = 6 ' نوع الحقل: Single (عدد عشري دقيق، ولكنه أقل دقة من Double) dbDouble = 7 ' نوع الحقل: Double (عدد عشري بدقة مزدوجة) dbDate = 8 ' نوع الحقل: Date (تاريخ/وقت) dbText = 10 ' نوع الحقل: Text (نص عادي يمكن تخزينه في الحقل) dbLongBinary = 11 ' نوع الحقل: Long Binary (بيانات ثنائية كبيرة الحجم) dbMemo = 12 ' نوع الحقل: Memo (نص طويل جدًا يمكن أن يحتوي على عدة آلاف من الأحرف) dbGUID = 15 ' نوع الحقل: GUID (معرف فريد عالميًا) dbBigInt = 16 ' نوع الحقل: Big Int (عدد صحيح كبير جدًا) dbVarBinary = 17 ' نوع الحقل: VarBinary (بيانات ثنائية متغيرة الحجم) dbNumeric = 19 ' نوع الحقل: Numeric (عدد عشري يستخدم عادة في الحسابات الدقيقة) dbMultipleChoice = 20 ' نوع الحقل: MultipleChoice (دعم الحقول متعددة الخيارات) dbAutoNumber = 21 ' نوع الحقل: AutoNumber (ترقيم تلقائي) End Enum ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' هذا الإجراء يقوم بإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldsTypes, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "", _ Optional defaultValue As Variant = Null _ ) ' إنشاء قاموس جديد لتخزين معلومات الحقل Dim fieldDict As Object Set fieldDict = CreateDictionary() ' إضافة الحقول إلى القاموس fieldDict("Name") = fieldName ' اسم الحقل fieldDict("Type") = fieldType ' نوع الحقل (من تعداد FieldsTypes) fieldDict("Caption") = fieldCaption ' التسمية التي تظهر في واجهة المستخدم (اختياري) fieldDict("Description") = fieldDescription ' وصف الحقل (اختياري) fieldDict("DefaultValue") = defaultValue ' القيمة الافتراضية (اختياري) ' التحقق مما إذا كان القاموس فارغًا، وإذا كان كذلك يتم تهيئته باستخدام قاموس جديد If Fields Is Nothing Then Set Fields = CreateObject("Scripting.Dictionary") ' إضافة القاموس الخاص بالحقل إلى القاموس العام باستخدام اسم الحقل كمفتاح Set Fields(fieldName) = fieldDict End Sub ' هذه الدالة تقوم بإنشاء قاموس جديد عند الحاجة إليها Public Function CreateDictionary() As Object ' إنشاء قاموس جديد باستخدام "Scripting.Dictionary" Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات Public Function TableExists(tableName As String) As Boolean Dim tdf As DAO.TableDef ' استعراض جميع الجداول في قاعدة البيانات For Each tdf In CurrentDb.TableDefs ' إذا كان اسم الجدول يتطابق مع الاسم المطلوب If tdf.Name = tableName Then '(الجدول موجود) إذا تم العثور على الجدول TableExists = True Exit Function End If Next tdf '(الجدول غير موجود) إذا لم يتم العثور على الجدول TableExists = False End Function ' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا Public Sub CreateTable(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() Set tdf = db.CreateTableDef(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' إضافة الحقول إلى الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إنشاء حقل جديد في الجدول If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If ' إذا كان هناك قيمة افتراضية يتم إضافتها If fieldDict.Exists("DefaultValue") And Not IsNull(fieldDict("DefaultValue")) Then fld.defaultValue = fieldDict("DefaultValue") End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf db.TableDefs.Refresh Application.RefreshDatabaseWindow ' تحرير المتغيرات Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub ' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول Public Function FieldExists(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 FieldExists = True Exit Function End If Next fld ' الحقل غير موجود FieldExists = False End Function ' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة Public Sub AddFieldsIfNeeded(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 ' البحث عن أول حقل من النوع AutoNumber في القاموس For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not FieldExists(tdf, fieldDict("Name")) Then If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If tdf.Fields.Append fld End If Next key End Sub ' هذا الإجراء يقوم بإضافة خصائص الحقول في الجدول Public Sub AddFieldProperties(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() Set tdf = db.TableDefs(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه If FieldExists(tdf, fieldDict("Name")) Then Set fld = tdf.Fields(fieldDict("Name")) ' إضافة أو تحديث التسمية ( عنوان الحقل/التسمية التي تظهر في واجهة المستخدم ) إذا كانت موجودة If fieldDict.Exists("Caption") And fieldDict("Caption") <> "" Then On Error Resume Next fld.Properties("Caption") = fieldDict("Caption") If Err.Number <> 0 Then Err.Clear Set prop = fld.CreateProperty("Caption", dbText, fieldDict("Caption")) fld.Properties.Append prop End If On Error GoTo 0 End If ' إضافة أو تحديث الوصف (الوصف) إذا كان موجودًا If fieldDict.Exists("Description") And fieldDict("Description") <> "" Then On Error Resume Next fld.Properties("Description") = fieldDict("Description") If Err.Number <> 0 Then Err.Clear Set prop = fld.CreateProperty("Description", dbText, fieldDict("Description")) fld.Properties.Append prop End If On Error GoTo 0 End If End If Next key End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه وإضافة البيانات إذا كانت موجودة Public Sub CreateOrUpdateTable(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb() If Not TableExists(tableName) Then CreateTable tableName, Fields Else Set tdf = db.TableDefs(tableName) AddFieldsIfNeeded tdf, Fields End If AddFieldProperties tableName, Fields Application.RefreshDatabaseWindow End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه بالإضافة إلى إضافة البيانات إذا كانت موجودة Public Sub CreateOrUpdateTableAndAddData(tableName As String, _ Fields As Object, _ Optional fieldValues As Object, _ Optional bAddData As Boolean = False _ ) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim rst As DAO.Recordset Dim key As Variant Dim fieldValue As Variant Dim isEmpty As Boolean Dim fieldName As String Set db = CurrentDb() If Not TableExists(tableName) Then CreateTable tableName, Fields Else Set tdf = db.TableDefs(tableName) AddFieldsIfNeeded tdf, Fields End If ' إضافة البيانات إذا كانت القيمة للعلم صحيحة If bAddData Then Set rst = db.OpenRecordset(tableName, dbOpenDynaset) isEmpty = (rst.RecordCount = 0) If isEmpty Then rst.AddNew For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) rst(fieldName) = fieldValue Next key rst.Update Else rst.MoveFirst For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) If IsNull(rst(fieldName)) Or (rst(fieldName) <> fieldValue) Then rst.Edit rst(fieldName) = fieldValue rst.Update End If Next key End If End If ' إضافة خصائص الحقول للجدول المحدد AddFieldProperties tableName, Fields ' تحديث نافذة قاعدة البيانات Application.RefreshDatabaseWindow End Sub لاستدعاء الكود بدون اضافة اى بيانات داخل الحقول ' هذا الإجراء يقوم بتهيئة الجدول فقط بدون البيانات الخاصة بالتصميم Public Sub SetupDesignerTableOnly() Dim tblName As String tblName = "UsysTblDesignerInformation" Set Fields = CreateDictionary() ' إضافة الحقول و معلومات كل حقل " اسم الحقل - نوع الحقل -التسمية التي تظهر في واجهة المستخدم (اختياري) - وصف الحقل (اختياري) - القيمة الافتراضية (اختياري) AddFieldToDictionary "ID", dbAutoNumber, "ID", "المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, "Designer Platform", "اسم المنصة" AddFieldToDictionary "FullName", dbText, "Full Name", "الاسم الكامل" AddFieldToDictionary "Email", dbText, "Email Address", "البريد الإلكتروني" AddFieldToDictionary "PhoneNumber", dbText, "Phone Number", "رقم الهاتف" AddFieldToDictionary "DesignSpecialty", dbText, "Design Specialty", "مجال التخصص" AddFieldToDictionary "PortfolioLink", dbText, "Portfolio Link", "رابط المحفظة" AddFieldToDictionary "CreationDate", dbDate, "Creation Date", "تاريخ التسجيل", "NOW()" ' إنشاء أو تحديث الجدول بالإضافة إلى إضافة البيانات CreateOrUpdateTableAndAddData tblName, Fields End Sub لاستدعاء الكود مع اضافة بيانات اجبارية للجداول ذات السجل الواحد مثلا كبيانات التطبيق او بيانات المصمم على سبيل المثال وليس الحصر ' هذا الإجراء يقوم بتهيئة البيانات الخاصة بالتصميم Public Sub SetupDesignerData() Dim fieldValues As Object Dim tblName As String tblName = "UsysTblDesignerInformation" Set Fields = CreateDictionary() Set fieldValues = CreateDictionary() ' إضافة الحقول و معلومات كل حقل " اسم الحقل - نوع الحقل -التسمية التي تظهر في واجهة المستخدم (اختياري) - وصف الحقل (اختياري) - القيمة الافتراضية (اختياري) AddFieldToDictionary "ID", dbAutoNumber, "ID", "المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, "Designer Platform", "اسم المنصة" AddFieldToDictionary "FullName", dbText, "Full Name", "الاسم الكامل" AddFieldToDictionary "Email", dbText, "Email Address", "البريد الإلكتروني" AddFieldToDictionary "PhoneNumber", dbText, "Phone Number", "رقم الهاتف" AddFieldToDictionary "DesignSpecialty", dbText, "Design Specialty", "مجال التخصص" AddFieldToDictionary "PortfolioLink", dbText, "Portfolio Link", "رابط المحفظة" AddFieldToDictionary "CreationDate", dbDate, "Creation Date", "تاريخ التسجيل", "NOW()" ' إضافة القيم الخاصة لكل حقل fieldValues("DesignerPlatform") = "Example Designer Platform™" fieldValues("FullName") = "Example Designer Name" fieldValues("Email") = "example.designer@email.com" fieldValues("PhoneNumber") = "+000 Example Designer Phone Number" fieldValues("DesignSpecialty") = "Example Designer Specialty" fieldValues("PortfolioLink") = "https://example.com/designer-portfolio" fieldValues("CreationDate") = Now ' إنشاء أو تحديث الجدول بالإضافة إلى إضافة البيانات CreateOrUpdateTableAndAddData tblName, Fields, fieldValues, True End Sub وكما ذكرت الموضوع مطروح للتجربة والنقاش .... اتمنى وارجوا من حضراتكم التفاعل بالنقاش وابداء الرأى

نعم ولكن طبعا يلزم صلاحيات لذلك فى وجود الصلاحيات كل شئ تمام

السلام عليكم ورحمة الله تعالى وبركاته الموضوع بخصوص انشاء مجلدات الموضوع مطروح للتجربه والنقاش بفكره جديده تشمل كل الاحتمالات تقريبا التى خطرت على بالى الاكواد فى وحدة نمطيه عامة كالاتى ' استيراد كائن FileSystemObject Private fso As Object ' تهيئة كائن FileSystemObject Private Sub InitializeFSO() If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject") End If End Sub ' فحص وجود مجلد باستخدام FileSystemObject Private Function FolderExists(path As String) As Boolean InitializeFSO FolderExists = fso.FolderExists(path) End Function ' إنشاء بنية مجلدات متدرجة Private Function CreateFolderStructure(fullPath As String, ByRef errorMessage As String) As Boolean On Error GoTo ErrorHandler Dim parts() As String Dim currentPath As String Dim i As Integer ' تقطيع المسار إلى أجزاء parts = Split(fullPath, "\") currentPath = "" ' إنشاء كل جزء من المسار بشكل متدرج For i = LBound(parts) To UBound(parts) If parts(i) <> "" Then currentPath = currentPath & parts(i) & "\" If Not FolderExists(currentPath) Then fso.CreateFolder currentPath End If End If Next CreateFolderStructure = True Exit Function ErrorHandler: ' تخزين رسالة الخطأ في حال حدوث مشكلة errorMessage = "تعذر إنشاء المجلد: " & fullPath & " - الخطأ: " & Err.Description CreateFolderStructure = False End Function ' بناء مسار كامل من المسار الأساسي والمسار الفرعي Private Function BuildPath(basePath As String, subPath As String) As String ' التأكد من انتهاء المسار الأساسي بشرطة ميل (/) If Right(basePath, 1) <> "\" Then basePath = basePath & "\" ' استبدال شرط الميل ("/") بشريط الميل ("\") BuildPath = basePath & Replace(subPath, "/", "\") End Function ' تنظيف المسار وإصلاح الأخطاء الشائعة Function BuildFullPath(rawPath As String) As String Dim cleanPath As String ' إزالة الفراغات الزائدة واستبدال الرموز غير الصحيحة cleanPath = Trim(rawPath) cleanPath = Replace(cleanPath, "/", "\") ' تصحيح الأخطاء في بداية المسار (C\Test ? C:\Test) If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" And (Asc(UCase(Left(cleanPath, 1))) >= 65 And Asc(UCase(Left(cleanPath, 1))) <= 90) Then cleanPath = Left(cleanPath, 1) & ":\" & Mid(cleanPath, 3) End If ' التحقق مما إذا كان المسار يبدأ بحرف قرص (مثل C:) لكنه لا يحتوي على \ بعده، وإصلاحه If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = ":" And Mid(cleanPath, 3, 1) <> "\" Then cleanPath = Left(cleanPath, 2) & "\" & Mid(cleanPath, 3) End If If Len(cleanPath) >= 2 And Mid(cleanPath, 2, 1) = "\" Then cleanPath = Left(cleanPath, 1) & ":\" & Right(cleanPath, Len(cleanPath) - 2) End If ' إذا لم يحتوي المسار على رمز قرص أو مسار شبكة، يتم ربطه بمسار المشروع الحالي If InStr(cleanPath, ":") = 0 And Left(cleanPath, 2) <> "\\" Then cleanPath = CurrentProject.path & "\" & cleanPath If Left(cleanPath, 1) = ":" Then cleanPath = CurrentProject.path & "\" & cleanPath ' تصحيح الأخطاء في كتابة المسارات cleanPath = Replace(cleanPath, "\:\", "\\") cleanPath = Replace(cleanPath, "\::\", "\") cleanPath = Replace(cleanPath, "\:", "\") ' استبدال \\ بـ \ باستثناء مسارات الشبكة \\Server\Share If Left(cleanPath, 2) <> "\\" Then cleanPath = Replace(cleanPath, "\\", "\") ' إرجاع المسار النظيف BuildFullPath = cleanPath End Function ' إنشاء مجلدات بناءً على قائمة مسارات فرعية Public Function CreateFolders(basePath As String, ParamArray folderPaths() As Variant) As String On Error GoTo ErrorHandler Dim path As Variant Dim fullPath As String Dim errorMessage As String InitializeFSO ' التحقق من وجود المسار الأساسي وإنشاؤه إذا لم يكن موجودًا If Not FolderExists(basePath) Then CreateFolderStructure basePath, errorMessage If errorMessage <> "" Then CreateFolders = errorMessage Exit Function End If End If ' إنشاء المسارات الفرعية For Each path In folderPaths fullPath = BuildPath(basePath, CStr(path)) If Not CreateFolderStructure(fullPath, errorMessage) Then CreateFolders = errorMessage Exit Function End If Next CreateFolders = "Success" Exit Function ErrorHandler: CreateFolders = "خطأ " & Err.Number & ": " & Err.Description End Function ' إنشاء مجلدات بناءً على بيانات جدول في قاعدة البيانات Public Function CreateFoldersFromTable(tableName As String, basePathField As String, Optional condition As String = "") As String On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim query As String Dim basePath As String Dim folderPath As String Dim errorMessage As String Set db = CurrentDb() ' بناء استعلام لاستخراج المسارات الفريدة query = "SELECT DISTINCT [" & basePathField & "] FROM [" & tableName & "]" If condition <> "" Then query = query & " WHERE " & condition Set rs = db.OpenRecordset(query, dbOpenSnapshot) ' التحقق من وجود سجلات If rs.BOF And rs.EOF Then CreateFoldersFromTable = "لا توجد سجلات." Exit Function End If ' إنشاء المجلدات لكل سجل Do While Not rs.EOF basePath = Nz(rs.Fields(basePathField).Value, "") folderPath = BuildFullPath(basePath) ' التحقق من صحة المسار وإنشاؤه If Not CreateFolderStructure(folderPath, errorMessage) Then CreateFoldersFromTable = errorMessage Exit Function End If rs.MoveNext Loop ' إغلاق السجلات وتنظيف الذاكرة rs.Close Set rs = Nothing Set db = Nothing CreateFoldersFromTable = "Success" Exit Function ErrorHandler: CreateFoldersFromTable = "خطأ " & Err.Number & ": " & Err.Description End Function ويتم الاستدعاء حسب خيال المبرمج وهذه امثله لصور الاستدعاء ' إنشاء مجلدات يدويا ً من خلال تمرير المسار Sub Example1() Dim result As String result = CreateFolders("C:\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات داخل مشروع Access الحالي Sub Example2() Dim result As String result = CreateFolders(CurrentProject.path & "\Project Resources", _ "Backup", _ "Fonts\Arabic", _ "Fonts\English", _ "Images\Ico", _ "Images\Logo", _ "Images\QR Code", _ "PDF", _ "Utility\Reference\MsAccess", _ "Utility\Reference\TBL") If result = "Success" Then MsgBox "تم إنشاء المجلدات داخل مشروع Access!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات من جدول في قاعدة البيانات Sub Example3() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات بنجاح!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على فئة معينة Sub Example4() Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = 'Access'") If result = "Success" Then MsgBox "تم إنشاء المجلدات الخاصة بمكتبات Access!", vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة (UNC Paths) Sub Example5() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath") If result = "Success" Then MsgBox "تم إنشاء المجلدات الشبكية بنجاح!", vbInformation Else MsgBox "حدث خطأ أثناء إنشاء المجلدات الشبكية: " & result, vbCritical End If End Sub ' إنشاء مجلدات شبكة بناءً على خادم معين Sub Example6() Dim result As String result = CreateFoldersFromTable("tblNetworkPaths", "UNCPath", "Server = 'FileServer01'") If result = "Success" Then MsgBox "تم إنشاء المجلدات على FileServer01!", vbInformation Else MsgBox "فشل في العثور على مجلدات لهذا الخادم: " & result, vbCritical End If End Sub ' إنشاء مجلدات بناءً على مدخلات المستخدم Sub Example7() Dim userCategory As String userCategory = InputBox("أدخل اسم الفئة لإنشاء المجلدات:", "تحديد الفئة") If userCategory <> "" Then Dim result As String result = CreateFoldersFromTable("tblFolderPaths", "FolderPath", "Category = '" & userCategory & "'") If result = "Success" Then MsgBox "تم إنشاء المجلدات للفئة: " & userCategory, vbInformation Else MsgBox "فشل في إنشاء المجلدات: " & result, vbCritical End If Else MsgBox "لم يتم إدخال فئة صحيحة!", vbExclamation End If End Sub الهدف: إنشاء مجلدات ديناميكيًا في مسار أساسي باستخدام معلومات مدخلة يدوية أو مستخلصة من قاعدة بيانات الحالات المختلفة للاستدعاء: الحالة 1: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الحالة 2: استدعاء دالة لإنشاء مجلد /هيكل المجلدات في مجلد مشروع Access الحالي الحالة 3: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول قاعدة بيانات الحالة 4: استدعاء دالة لإنشاء مجلد /هيكل المجلدات من خلال مسارات من جدول مع تصفية حسب فئة معينة الحالة 5: استدعاء دالة لإنشاء مجلد /هيكل المجلدات يدويا ً من خلال تمرير المسار الشبكي(UNC) الحالة 6: استدعاء دالة لإنشاء المجلدات من خلال مسارات من جدول مع تصفية حسب اسم الخادم المستخدم للمسار الشبكي (UNC) انشاء مجلد او هيكل مجلدات.zip

واو الموضوع كبـــــــر يسعدنى ان اشارك عظماء المنتدى واساتذتى الأجلاء فى هذه الافكار ولا اخفيكم انه وسام شرف ان يذكر اسم العبد الفقير طويلب العلم بجوار اساتذة واعمدة المنتدى طيب وما رأيكم استاذ @jjafferr و استاذ @AbuuAhmed فى الكود التالى Dim t As Double, currentID As Long t = Timer With Me If .Dirty Then .Dirty = False currentID = !ID End With Dim db As DAO.Database Set db = CurrentDb db.Execute "UPDATE employees SET y_n = False WHERE y_n = True;", dbFailOnError db.Execute "UPDATE employees SET y_n = True WHERE ID = " & currentID & ";", dbFailOnError With Me .Requery If .Recordset.RecordCount > 0 Then .Recordset.FindFirst "ID = " & currentID End If End With Debug.Print "الوقت المستغرق: " & Timer - t & " ثانية"

طيب وممكن رايكم بالكود التالى Private Sub y_n_Click() On Error GoTo ErrorHandler Dim sql As String Dim currentID As Variant ' حفظ السجل الحالي If Me.Dirty Then Me.Dirty = False End If ' الحصول على معرف السجل الحالي currentID = Me!id ' تحديث كافة السجلات لإلغاء التحديد sql = "UPDATE a SET y_n = False" CurrentDb.Execute sql, dbFailOnError ' تعيين السجل الحالي فقط sql = "UPDATE a SET y_n = True WHERE ID = " & currentID CurrentDb.Execute sql, dbFailOnError ' تحديث النموذج لإظهار التغييرات Me.Requery ' العودة إلى السجل الحالي Me.Recordset.FindFirst "ID = " & currentID Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbExclamation, "Error" Debug.Print "حدث خطأ: " & Err.Number & "|" & Err.Description Exit Sub End Sub HH.accdb

اتفضل ss (2Saad-1).zip

ابدا فى وضع التحليل المناسب والتصور الامثل لاحتياجات وابدأ فى انشاء قاعدة البيانات وفقا لذلك ان تعثرت فى تنفيذ اى شئ ارجع الى الموضوع واسال وان شاء الله تجد الدعم المناسب ودعنى اضع لك اللبنة الاولى بشكل عام ولكن قد تكون مخالفة لمتطلباتك او رغباتك او الية العمل لذلك خذ فكرة مما اعرضه عليه فذلك سوف يفتح لك افاق التصور والتخيل الصحيح ليضعك على البداية الصحيحة للمسار الامثل لانشاء قاعدة بياناتك 1. الجداول (Tables) أ. جدول الكتب (Books) الحقول: BookID: مفتاح أساسي (رقمي تلقائي). Title: عنوان الكتاب (نصي). Author: اسم المؤلف (نصي). ISBN: رقم ISBN (نصي، فريد). Publisher: الناشر (نصي). PublicationYear: سنة النشر (تاريخ). GenreID: مفتاح خارجي (يرتبط بجدول التصنيفات). Language: اللغة (نصي). TotalCopies: عدد النسخ الإجمالي (رقمي). AvailableCopies: عدد النسخ المتاحة (رقمي). ShelfLocation: موقع الكتاب على الرف (نصي). ملاحظات إضافية: إذا كان لديك مؤلفون متعددون لنفس الكتاب، يمكن فصل المؤلفين إلى جدول مستقل (Authors) مع جدول وسيط (BookAuthors). إضافة حقل مثل BookDescription لتقديم وصف موجز عن الكتاب قد يكون مفيدًا. ب. جدول الأعضاء (Members) الحقول: MemberID: مفتاح أساسي (رقمي تلقائي). FirstName: الاسم الأول (نصي). LastName: الاسم الأخير (نصي). Email: البريد الإلكتروني (نصي، فريد). Phone: رقم الهاتف (نصي). Address: العنوان (نصي). MembershipDate: تاريخ الانضمام (تاريخ). Status: حالة العضوية (نشيط/غير نشيط، نصي أو منطقي). ملاحظات إضافية: يمكن إضافة حقل MembershipType لتحديد نوع العضوية (مثل عادية أو مميزة). حقل Notes قد يكون مفيدًا لتسجيل أي ملاحظات إضافية. ج. جدول الإعارات (Borrowings) الحقول: BorrowID: مفتاح أساسي (رقمي تلقائي). MemberID: مفتاح خارجي يرتبط بجدول الأعضاء. BookID: مفتاح خارجي يرتبط بجدول الكتب. BorrowDate: تاريخ الإعارة (تاريخ). DueDate: تاريخ الاستحقاق (تاريخ). ReturnDate: تاريخ الإرجاع (تاريخ). Status: حالة الإعارة (معارة/مرجعة/متأخرة). ملاحظات إضافية: يمكن إضافة حقل FineAmount لتسجيل الغرامة عند تأخر الإرجاع. د. جدول التصنيفات (Genres) الحقول: GenreID: مفتاح أساسي (رقمي تلقائي). GenreName: اسم التصنيف (نصي). 2. العلاقات بين الجداول (Relationships) العلاقات: Books.GenreID ↔ Genres.GenreID: علاقة واحد إلى متعدد. Borrowings.MemberID ↔ Members.MemberID: علاقة واحد إلى متعدد. Borrowings.BookID ↔ Books.BookID: علاقة واحد إلى متعدد. ملاحظات: تأكد من تعريف العلاقات في Access وربط الجداول بمفاتيحها الأساسية. قم بتمكين التكامل المرجعي (Referential Integrity) لتجنب إدخال بيانات غير متطابقة. 3. تحسينات إضافية جدول المؤلفين (Authors)اختياري: AuthorID: مفتاح أساسي. AuthorName: اسم المؤلف. ثم إنشاء جدول وسيط BookAuthors: BookID: مفتاح خارجي من جدول الكتب. AuthorID: مفتاح خارجي من جدول المؤلفين. جدول الغرامات (Fines): FineID: مفتاح أساسي. BorrowID: مفتاح خارجي من جدول الإعارات. FineAmount: مبلغ الغرامة. واجهة المستخدم (Forms): إنشاء واجهات سهلة الاستخدام لإضافة الكتب، إدارة الأعضاء، وتتبع الإعارات. إضافة تقارير لإحصائيات المكتبة (مثل الكتب الأكثر استعارة). الاستعلامات (Queries): استعلام لتحديد الكتب المتأخرة عن الإرجاع. استعلام لتقرير الأعضاء النشطين.

مش عارف انا عارف افهمك واللا لاء جرب استخدام الاكواد التاليه Sub DuplicateRecords() Dim db As DAO.Database Dim rs As DAO.Recordset Dim newPCode As Long Dim todayDate As Date Dim sqlInsertLab As String Dim sqlInsertRequest As String Dim sqlInsertTests As String ' فتح قاعدة البيانات الحالية Set db = CurrentDb() todayDate = Date ' جلب آخر PCode من جدول tbl_NewLab لتجنب التكرار Set rs = db.OpenRecordset("SELECT MAX(PCode) AS MaxPCode FROM tbl_NewLab") If Not rs.EOF Then newPCode = rs!MaxPCode + 1 Else newPCode = 1 ' في حالة عدم وجود سجلات End If rs.Close ' استبدال المرجع بالصيغة الصحيحة Dim currentPCode As Long currentPCode = Forms!New_Project!newRequest.Form!PCode ' إدراج السجل الجديد في tbl_NewLab sqlInsertLab = "INSERT INTO tbl_NewLab (DDate, PCode, Pname, Name_Month, C_Year, Area, Code_Month, Mon_Year) " & _ "SELECT #" & todayDate & "#, " & newPCode & ", Pname, Name_Month, C_Year, Area, Code_Month, Mon_Year " & _ "FROM tbl_NewLab WHERE PCode = " & currentPCode db.Execute sqlInsertLab ' إدراج السجل الجديد في tbl_NewRequest sqlInsertRequest = "INSERT INTO tbl_NewRequest (PCode, TCode, Date_R, Price_R, Tname_R) " & _ "SELECT " & newPCode & ", TCode, #" & todayDate & "#, Price_R, Tname_R " & _ "FROM tbl_NewRequest WHERE PCode = " & currentPCode db.Execute sqlInsertRequest ' إدراج السجل الجديد في tbl_NewTests (إذا لزم الأمر) sqlInsertTests = "INSERT INTO tbl_NewTests (TCode, TName, Price) " & _ "SELECT TCode, TName, Price " & _ "FROM tbl_NewTests WHERE TCode IN (SELECT TCode FROM tbl_NewRequest WHERE PCode = " & currentPCode & ")" db.Execute sqlInsertTests MsgBox "تم تكرار السجل بنجاح مع تحديث PCode والتاريخ.", vbInformation End Sub Private Sub أمر4030_Click() DuplicateRecords End Sub

جرب الكود التالى Public Function DivideIntoColumns(totalNumber As Integer, columnIndex As Integer) As Integer Static result(1 To 6) As Integer Static lastNumber As Integer Dim remaining As Integer Dim i As Integer Dim randNum As Integer ' حدود الأعمدة Dim maxLimits(1 To 6) As Integer maxLimits(1) = 20 maxLimits(2) = 20 maxLimits(3) = 20 maxLimits(4) = 20 maxLimits(5) = 10 maxLimits(6) = 5 ' Reset results if the input number changes If lastNumber <> totalNumber Then lastNumber = totalNumber remaining = totalNumber ' Initialize the result array to zero For i = 1 To 6 result(i) = 0 Next i ' Step 1: Ensure each column has at least 2 For i = 1 To 6 If remaining >= 2 Then result(i) = 2 remaining = remaining - 2 End If Next i ' Step 2: Distribute remaining values randomly while respecting max limits Randomize While remaining > 0 i = Int((6) * Rnd) + 1 ' Random column (1 to 6) ' Check if the column can accept more values without exceeding its max limit If result(i) < maxLimits(i) Then randNum = IIf(remaining > maxLimits(i) - result(i), maxLimits(i) - result(i), remaining) result(i) = result(i) + randNum remaining = remaining - randNum End If Wend End If ' Return the value for the requested column DivideIntoColumns = result(columnIndex) End Function والاستعلام سوف يكون بناء على الكود كالتالى SELECT Table1.MyNum, DivideIntoColumns([MyNum],1) AS Col1, DivideIntoColumns([MyNum],2) AS Col2, DivideIntoColumns([MyNum],3) AS Col3, DivideIntoColumns([MyNum],4) AS Col4, DivideIntoColumns([MyNum],5) AS Col5, DivideIntoColumns([MyNum],6) AS Col6 FROM Table1;

هههههههه انا حسيت ان فى شئ غير صحيح وكنت استحى ان اذكر ذلك توقعت اننى المخطئ فى فهمى

اعرف انه لم يعط نتيجه انا بصراحة لم افهم منطق النتيجة ممكن اتقل على حضرتك ومن واقع النتيجة بالجدولين والاستعلام Query1 حضرتك تقول لى ايه اللى المفروض يحصل بناء على رغبتك بالقيم المفروض النتيجة هنا تكون ايه طيب Table1 ID userID chek1 1 aa 1 2 aa 1 3 cc 1 4 cc 1 5 gg 1 لان دى نتيجة الاستعلام Query1 user_ID p1 p2 pp aa 40 30 10 bb 60 60 0 gg 40 25 15 الاستعلام يوضح ان القيمة bb للحقل user_ID وهو حقل الربط اللى حضرتك عاوز تستخدمه فى استعلام التحديث هى التى تحقق معها الشرط فى الحقل PP = 0 طيب بما ان user_ID قيمته كات عند تحقيق الشرط هى : bb اين هذه القيمه القيمه فى الجدول Table1 بالنسبة للحقل الربط : userID المستخدم فى الربط فى استعلام التحديث لذلك الاستعلام الفرعى لم يعط اى نتائج ولكن لو كانت القيمة موجودة لعمل الاستعلام هذا ما فهمته انا من التحليل

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل اعتقد لا يمكن عمل ذلك فان الاستعلام Query1 غير قابل للتحديث لانه يحتوى على دوال تجميع SUM بدلاً من استخدام Query1 مباشرة في عملية التحديث اعتقد لو كنت قدرت افهم صح ممكن استخدام استعلام فرعي (Subquery) داخل جملة التحديث بشكل مباشر UPDATE Table1 SET Table1.chek1 = 0 WHERE Table1.userID IN ( SELECT Table2.user_ID FROM Table2 GROUP BY Table2.user_ID HAVING CLng(Sum(Table2.price1)) - CLng(Sum(Table2.price2)) = 0 );

اتفضل dodo - 3.zip

وده المرفق للتطبيق ومعاك فكرتين الاولى التى تعتمد على الاكواد والثانية التى تعتمد على الاستعلام dodo - 2.zip

وممكن كده برضو SELECT student.id_stu, student.name, student.saf_id, student.totale, student.galose, student.fasle, student.birth, Tbl_saf.saf_id, Tbl_saf.saf FROM student INNER JOIN Tbl_saf ON student.saf_id = Tbl_saf.saf_id WHERE student.saf_id = [Forms]![form1]![cc] AND (SELECT COUNT(*) FROM student AS s2 WHERE s2.saf_id = student.saf_id AND (s2.totale > student.totale OR (s2.totale = student.totale AND s2.birth < student.birth) OR (s2.totale = student.totale AND s2.birth = student.birth AND s2.name < student.name)) ) < 10 ORDER BY student.saf_id, student.totale DESC , student.birth, student.name;

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip