ابو جودي

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

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

دى فكرتى فى وحدة نمطيه عامة نضع الكود التالى Public Sub SplitNationalID(formOrReport As Object, nationalID As String) Dim i As Integer Dim ctrl As Control ' التأكد من أن الرقم القومي يحتوي على 14 رقمًا If Len(nationalID) <> 14 Then MsgBox "الرقم القومي يجب أن يتكون من 14 رقمًا!", vbExclamation Exit Sub End If ' فصل الرقم القومي إلى أرقام فردية وتعيينها إلى مربعات النص For Each ctrl In formOrReport.Controls If TypeName(ctrl) = "TextBox" And Left(ctrl.Name, 3) = "txt" Then i = Val(Mid(ctrl.Name, 4)) ' استخراج الرقم من اسم مربع النص (مثل txt1, txt2, إلخ) If i >= 1 And i <= 14 Then ctrl.Value = Mid(nationalID, i, 1) End If End If Next ctrl End Sub على ان يكون فى النموذج عدد 15 مربع النص مربع النص الاول يكون باسم : txtNationalID والباقى تكون اسمائهم txt1 الى txt14 وزر امر عند الضغط عليه يتم استدعاء الدالة بالشكل التالى SplitNationalID Me, Me.txtNationalID.Value ونفس الموضوع للتقرير على ان يتم الاستدعاء عند الفتح وانا اكتب انت تضع المرفق لا وبتفكر زى افكار بس انا فكرتى اكثر مرونه منك 😛😄

ايه ده مش ممكن نفكر بمرونه شويه يا ناس ؟ افضل انا اكتب اسماء ال 14 مربع نص فاضى انا بقه صح طبعا امزح مع استاذى و معلمى الاستاذ القدير @AlwaZeeR

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

ممكن كتابة الكود التالى فى ملف Text ثم بعد ذلك حفظ الملف باسم : UnblockDatabase.ps1 حتى يكون الملف الناتج عبارة عن ملف : PowerShell ويتم تشعيل الملف كمسئول وظيفة الكود الدوران على قواعد البيانات الموجوده فى المجلد الحالى او المجلدات الفرعيه للمجلد الحالى وازالة الحظر لهذه القواعد واقصد بالحظر هنا الموجودة بالصورة التاليه # التحقق من صلاحيات المسؤول if (-not ([Security.Principal.WindowsPrincipal] [Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole] "Administrator")) { Write-Host "❌ يجب تشغيل السكربت بصلاحيات المسؤول لتعيين سياسة التنفيذ." exit } # تعيين سياسة التنفيذ Set-ExecutionPolicy -Scope LocalMachine -ExecutionPolicy RemoteSigned -Force Write-Host "✅ تم تعيين سياسة التنفيذ إلى RemoteSigned على مستوى الجهاز." # الحصول على المسار الحالي للمجلد الذي يحتوي على الكود $currentFolder = $PSScriptRoot # البحث عن جميع ملفات قواعد البيانات (مثل *.accdb و *.mdb) في المجلد الحالي والمجلدات الفرعية $databaseFiles = Get-ChildItem -Path $currentFolder -Include *.accdb, *.mdb -Recurse # التحقق من وجود ملفات قاعدة البيانات if ($databaseFiles) { foreach ($file in $databaseFiles) { try { # إزالة الحظر من الملف $zoneIdentifier = "$($file.FullName):Zone.Identifier" if (Test-Path $zoneIdentifier) { Remove-Item -Path $zoneIdentifier -Force Write-Host "تم إزالة الحظر من الملف: $($file.FullName)" } else { Write-Host "الملف غير محظور: $($file.FullName)" } } catch { Write-Host "حدث خطأ أثناء محاولة إزالة الحظر من الملف: $($file.FullName) - $_" } } } else { Write-Host "لم يتم العثور على ملفات قاعدة بيانات في المجلد الحالي." } UnblockDatabase.zip

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

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