ابو البشر

شكرا لاخي @ابو جودي سبقني بالحل الناجع ............................. ولكني حاولت تجميع فكرة في تصميم برنامج خاص بتعديل خصائص العناصر ::: مميزاته::::: - ممكن استخدامه للقاعدة الحالية أو قاعدة خارجية - اختيار الشكل المناسب من بين مجموعة اشكال ممكن يحتفظ بها المصمم لبرامج اخرى - اختيار نموذج من القاعدة الحالية او نموذج القاعدة الخارجية لمعاينة الشكل ( طبعا المعاينة لا تغير من خصائص عناصر النموذج ولكن للمشاهدة فقط) - يمكن تعديل الشكل ومعاينة النموذج المختار - بعد اختيار الشكل المناسب يتم الضغط عل تطبيق فيتم تطبيق الشكل على كامل النماذج في القاعدة ( سواءا الحالية _ او الخارخية ) - للاسف لم يسعفني الوقت لاكمال التصميم بسبب انشغالي هذه الفترة

تفضل ................................ Public Function CustomizeAllFormSections() Dim frm As Object Dim ctl As Control Dim section As section Dim sectionsToProcess As Variant Dim i As Integer ' قائمة المقاطع التي نريد معالجتها sectionsToProcess = Array(acHeader, acDetail, acFooter) For Each frm In CurrentProject.AllForms On Error Resume Next ' لتجاوز الأخطاء ' فتح النموذج في وضع التصميم DoCmd.OpenForm frm.Name, acDesign, , , , acHidden If Err.Number <> 0 Then Debug.Print "تعذر فتح النموذج: " & frm.Name Err.Clear GoTo SkipForm End If ' معالجة كل مقطع For i = LBound(sectionsToProcess) To UBound(sectionsToProcess) If Not Forms(frm.Name).section(sectionsToProcess(i)) Is Nothing Then Set section = Forms(frm.Name).section(sectionsToProcess(i)) ' تحديد ألوان فريدة لكل مقطع وعناصره Select Case sectionsToProcess(i) Case acHeader ' الرأس section.BackColor = RGB(173, 216, 230) ' أزرق فاتح ' ألوان عناصر الرأس For Each ctl In section.Controls Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox ctl.BackColor = RGB(240, 248, 255) ' أزرق شاحب ctl.BorderColor = RGB(70, 130, 180) ' أزرق داكن Case acLabel ctl.BackColor = RGB(173, 216, 230) ' نفس خلفية الرأس ctl.ForeColor = RGB(0, 0, 139) ' أزرق داكن ctl.BackStyle = 1 Case acCommandButton ctl.BackColor = RGB(100, 149, 237) ' أزرق متوسط ctl.ForeColor = RGB(255, 255, 255) ' أبيض Case acCheckBox, acOptionButton ctl.BackColor = RGB(240, 248, 255) ' أزرق شاحب ctl.ForeColor = RGB(0, 0, 0) ' أسود End Select Next ctl Case acDetail ' التفاصيل section.BackColor = RGB(255, 255, 200) ' أخضر شاحب ' ألوان عناصر التفاصيل For Each ctl In section.Controls Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox ctl.BackColor = RGB(255, 255, 255) ' أبيض ctl.BorderColor = RGB(144, 238, 144) ' أخضر فاتح Case acLabel ctl.BackColor = RGB(240, 248, 240) ' نفس خلفية التفاصيل ctl.ForeColor = RGB(0, 100, 0) ' أخضر داكن ctl.BackStyle = 1 Case acCommandButton ctl.BackColor = RGB(144, 238, 144) ' أخضر فاتح ctl.ForeColor = RGB(0, 0, 0) ' أسود Case acCheckBox, acOptionButton ctl.BackColor = RGB(255, 255, 255) ' أبيض ctl.ForeColor = RGB(0, 0, 0) ' أسود End Select Next ctl Case acFooter ' التذييل section.BackColor = RGB(255, 228, 225) ' وردي فاتح ' ألوان عناصر التذييل For Each ctl In section.Controls Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox ctl.BackColor = RGB(255, 250, 250) ' وردي شاحب ctl.BorderColor = RGB(205, 92, 92) ' بني محمر Case acLabel ctl.BackColor = RGB(255, 228, 225) ' نفس خلفية التذييل ctl.ForeColor = RGB(139, 0, 0) ' أحمر داكن ctl.BackStyle = 1 Case acCommandButton ctl.BackColor = RGB(205, 92, 92) ' بني محمر ctl.ForeColor = RGB(255, 255, 255) ' أبيض Case acCheckBox, acOptionButton ctl.BackColor = RGB(255, 250, 250) ' وردي شاحب ctl.ForeColor = RGB(0, 0, 0) ' أسود End Select Next ctl End Select End If Next i CloseForm: ' حفظ وإغلاق النموذج DoCmd.Close acForm, frm.Name, acSaveYes SkipForm: On Error GoTo 0 Err.Clear Next End Function

طيب جرب هذا .... Public Function ModifyFormsBackground() Dim frm As Object Dim ctl As Control For Each frm In CurrentProject.AllForms ' افتح النموذج في وضع التصميم DoCmd.OpenForm frm.Name, acDesign ' تغيير لون خلفية مقطع التفاصيل Forms(frm.Name).Detail.BackColor = RGB(240, 240, 240) ' لون فاتح رمادي ' تغيير خلفية العناصر داخل مقطع التفاصيل For Each ctl In Forms(frm.Name).Detail.Controls ' تغيير خلفية العناصر حسب نوعها Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox ctl.BackColor = RGB(255, 255, 255) ' أبيض Case acLabel ctl.BackColor = RGB(240, 240, 240) ' نفس لون خلفية المقطع ctl.BackStyle = 1 ' خلفية معتمة End Select Next ctl ' احفظ وأغلق النموذج DoCmd.Close acForm, frm.Name, acSaveYes Next End Function

وهذا ايضا Public Function ChangeFormsDetailBackColor() On Error Resume Next Dim objForm As AccessObject Dim frm As Form Dim newColor As Long newColor = RGB(230, 255, 230) ' لون أخضر فاتح - يمكنك تغييره For Each objForm In CurrentProject.AllForms DoCmd.OpenForm objForm.Name, acDesign, , , , acHidden Set frm = Forms(objForm.Name) If Not frm Is Nothing Then ' تحقق من وجود مقطع التفاصيل If frm.Section(acDetail).Visible Then frm.Section(acDetail).BackColor = newColor End If DoCmd.Close acForm, objForm.Name, acSaveYes End If Next objForm Set frm = Nothing End Function عفوا لم انته للتعدي ... يبدو ردي وقت التعديل

لم اجرب الكود ... جرب استاذنا الغالي التعديل التالي Public Function funforms() Dim frm As Object Dim frmDesign As Form For Each frm In CurrentProject.AllForms DoCmd.OpenForm frm.Name, acDesign Set frmDesign = Forms(frm.Name) ' تغيير خصائص النموذج frmDesign.PopUp = True ' تغيير لون خلفية مقطع التفاصيل (مثلاً إلى لون رمادي فاتح) frmDesign.Section(acDetail).BackColor = RGB(240, 240, 240) DoCmd.Close acForm, frm.Name, acSaveYes Next frm End Function تأكد من أن جميع النماذج ليست مفتوحة في وضع "عرض" أو "تصميم" قبل تنفيذ الوظيفة

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

ممكن توضيح اكثر هل البرنامج من تصميمك ام على البرنامج حماية وايش المقصودتعديل بيانات ونماذج واذا امكن مرفق للنظر والتامل فيه

هناك أسباب عديدة لظهورها أسباب محتملة: خطأ في اسم الجدول أو الاستعلام: إذا كنت تستخدم DoCmd.OpenQuery أو DoCmd.OpenForm، فتأكد من أن اسم العنصر صحيح. قيمة غير صالحة في دالة مثل DLookup أو DSum: تحقق من أن القيم التي تمررها إلى الدالة صحيحة. متغير غير مهيأ أو فارغ: إذا كنت تمرر متغيرًا إلى الدالة، فتأكد من أنه يحتوي على قيمة صالحة. عدم تطابق في أنواع البيانات: إذا كنت تمرر رقمًا إلى وسيطة تتطلب نصًا أو العكس. وجود أحرف خاصة في الاسم: تأكد من أن أسماء الجداول أو الحقول لا تحتوي على مسافات أو رموز غير متوافقة.

اولا : بارك الله فيك استاذي @Foksh الذي كنت سببا في قدح الفكرة في رأسنا وحاول الطالب مجارات المعلم ثانيا : سامحني على اقتباس الفكرة والبرمجة على اساسها ثالثا: اضفت بعض الاضافات :::::::::::: * نقل الملفات من مجلد الى اخر * اعادة تسمية الملفات * حذف الملف * يمكن تحديد المجلد للرفع له * تصفية ملفات المجلد فقط * مجرد اختيار الملف في قائمة ملفات قوقل يظهر رابط التحميل بثلاث طرق 1- تحميل الملفات الصغيرة 2- تحميل الملفات الكبيرة 3- عرض الملف في المتصفح * هناك تعديلات قائمة ........

بارك الله فيك وعى سرعة استجابتك كتب الله أجرك ورحم الله والدينا ووالديك

اولا : غفر الله لوالدك ووالدينا واللهم ارحمه، ووسّع نزله، وأكرم مدخله، ثانيا عمل غاية الابداع ولك الشكر على ذلك ... بارك الله فيك ثالثا : استخدمت النسخة 32 bit لم تظهر لدي المجلدات ولا يتم تكوين مجلد رابعا : بالنسبة للملفات ذات التسمية العربية لا يرفعها بنفس الاسم وتجد الملف فقط بالامتداد الخاص بها بدون اسم وهل نري قريبا اختيار متعدد للملفات ليتم رفعها دفعة واحدة خامسا : طلب وليس امر ان حققته فهذا كرم منك والا فهو اقل حقوقك ... لو امكن شرح لطريقة البرمجة التي اتبعتها .... جزاك الله خيرا

كرري التحديث للنماذج الثلاث Private Sub n1_Change() [Form1].Requery [Form2].Requery [Form3].Requery End Sub

وهذه طريقة اخرى .... Database1 (33).accdb

تفضل Database1 (33).accdb

جرب هذا ........................ Sub CleanAndRemovePatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim updatedText As String Dim regExp As Object On Error GoTo ErrorHandler Set db = CurrentDb Set rs = db.OpenRecordset("SELECT ID, nass FROM book", dbOpenDynaset) strPattern = "&\d+&&" Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True Do While Not rs.EOF If Not IsNull(rs!nass) Then strInput = rs!nass updatedText = strInput If regExp.Test(updatedText) Then updatedText = regExp.Replace(updatedText, "") End If If Left(updatedText, 2) = vbCrLf Then updatedText = Mid(updatedText, 3) ElseIf Left(updatedText, 1) = vbLf Then updatedText = Mid(updatedText, 2) ElseIf Left(updatedText, 1) = vbCr Then updatedText = Mid(updatedText, 2) End If updatedText = LTrim(updatedText) If strInput <> updatedText Then rs.Edit rs!nass = updatedText rs.Update End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تمت إزالة الأنماط والسطر الفارغ بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Set regExp = Nothing End Sub