ابو جودي

طيب استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل يبدو ان الفكرة هذه تخص تسجيل اجازة او مأمورية او تدريب او شئ من هذا القبيل بين فترين أولا انا حاولت وضع كل الاجابات وكل ما خطر بالى فيما يخص السؤال والموضوع بقدر الامكان حسب فهمى المتواضع ولكن ولكن لكن وبناء على تجارب عملية الافضل هو تسجيل التواريخ جميعا من خلال لوب بداية من اول تاريخ الى اخر تاريخ فى الجدول المخصص من البداية على هيئة سجلات الميزة والافضلية اولا لاى سبب عارض اى تغيير فى المستقبل بين الفترات يسهل حذفه وناهيك عن سهولة تطبيق باقى العمليات والاجراءات التى تخطر على بالك فى الوقت الراهن او لم تخطر حتى الان وقدم تسبب مشاكل فى المستقبل والتى فى النهاية جعلتك تحاول تفكيك التواريخ الى سجلات لنعطى مثال صغير وهذا طبقته بشكل عملى فى مؤسستى لنفترض ان موظف ما قدم طلب اجازة اعتيادية مثلا من يوم 1/7/2025 وحتى 10/7/2025 تتم عملية التسجيل لكل تاريخ سجل منفرد بكود الموظف والتاريخ ونوع اليومية مع استبعاد ايام العطلات من اللوب سواء كانت رسمية او غير رسمية الميزة هنا : عدد السجلات لهذا الموظف وحسب نوع اليومية هو اجمالى ما حصل الموظف عليه او سوف يحصل عليه لهذا النوع ان كانت فى تواريخ مستقبلية طيب لنفترض ان عدد السجلات كان 7 اذا هو يمثل 7 ايام ب 7 تواريخ من تاريخ البدء وحتى تاريخ الانتهاء طيب لفترض ان الموظف اخذ فقط يومين وقطع الاجازة وعاد الى العمل ولم يخبر المختص لاعادة التعديل لأى سبب حتى يتم اعادة ضبط الرصيد وفق الواقع انا صممت استعلام يبدأ مع فتح نموذج التسجيل يطابق هذا الجدول مع جدول الحضور الخاص بالبصمة و وفق التواريخ التى لها بصمة حضور وتساوت مع تواريح فى جدول اليوميات مثلا على انها اجازة يتم حذفها تلقائيا من جدول الاجازات بذلك يتم تصحيح الرصيد بشكل الى وبدون تدخل بشرى اعتقد فرد التواريخ من البداية ليكون كل تاريخ فى سجل له الافضلية ويضفى المرونة القصوى اثناء معالجة البيانات ويلبى العديد من الرغبات بشتى الافكار حسب المتطلبات الحالية أو التى تطرأ فى المستقبل

طيب دى فكرة تانى لو لا تريد عمل جداول مؤقته او حتى جدول ثابت لمعالجة موضوع التواريخ وان كنت لا تريد كذلك الاعتماد على جداول مساعدة كالجدول الاخير : tbl2 الكود Public Sub GenerateSafeUnionQuery() Dim db As DAO.Database Dim rs As DAO.Recordset Dim dtmStart As Date, dtmEnd As Date, dtmCurrent As Date Dim lngUserID As Long Dim strSQL As String Dim strOneLine As String Dim bolFirst As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("SELECT user_id, startA, endA FROM tbl1", dbOpenSnapshot) bolFirst = True Do Until rs.EOF lngUserID = rs!user_id dtmStart = Nz(rs!startA, 0) dtmEnd = Nz(rs!endA, 0) If IsDate(dtmStart) And IsDate(dtmEnd) And dtmStart <= dtmEnd Then For dtmCurrent = dtmStart To dtmEnd ' استخدام جدول فعلي لتجنب التكرارات strOneLine = "SELECT " & lngUserID & " AS user_id, #" & Format(dtmCurrent, "yyyy-mm-dd") & "# AS dateField FROM (SELECT TOP 1 * FROM tbl1)" If bolFirst Then strSQL = strOneLine bolFirst = False Else strSQL = strSQL & vbCrLf & "UNION ALL" & vbCrLf & strOneLine End If Next dtmCurrent End If rs.MoveNext Loop rs.Close Set rs = Nothing ' حذف الاستعلام القديم (لو موجود) On Error Resume Next db.QueryDefs.Delete "qryUnioUserDates" db.QueryDefs.Delete "qryFinalUserDates" On Error GoTo 0 ' إنشاء الاستعلام الأساسي UNION db.CreateQueryDef "qryUnioUserDates", strSQL ' إنشاء استعلام مبني عليه db.CreateQueryDef "qryFinalUserDates", "SELECT * FROM qryUnioUserDates;" ' إظهار الاستعلام مباشرة DoCmd.OpenQuery "qryFinalUserDates", acViewNormal MsgBox "تم إنشاء الاستعلامين بنجاح، والاستعلام النهائي تم فتحه.", vbInformation End Sub طبعا الاستدعاء للدالة : GenerateSafeUnionQuery يقوم بعمل استعلامين بشكل ديناميكى الاساسى : qryUnioUserDates ومبنى عليه الاستعلام الثانى : qryFinalUserDates والذى نتيجته كما هو مطلوب تماما ولكن يعيب هذه الفكرة شئ واحد لابد من استدعاء الداله دائما : GenerateSafeUnionQuery مع اى تحديث يتم على الجدول : tbl1 ---------------------------- أفكار أخرى لا تعتمد على جدول مساعد او جدول مؤقت او حتى جدول ثابت الكود الاساسى فى وحده نمطية عامة Private Const adInteger = 3 Private Const adDBTimeStamp = 135 Private Const adOpenStatic = 3 Private Const adLockOptimistic = 3 Public Function GetSplitDatesRecordset() As Object Dim db As DAO.Database Dim rsSource As DAO.Recordset Dim rsTemp As Object Dim arrDates() As String Dim i As Long Dim lngUserID As Long Dim strDates As String Set rsTemp = CreateObject("ADODB.Recordset") rsTemp.Fields.Append "user_id", adInteger rsTemp.Fields.Append "SingleDate", adDBTimeStamp rsTemp.CursorType = adOpenStatic rsTemp.LockType = adLockOptimistic rsTemp.Open Set db = CurrentDb Set rsSource = db.OpenRecordset("SELECT user_id, GetDatesBetween([startA], [endA]) AS DateList FROM tbl1", dbOpenSnapshot) Do While Not rsSource.EOF lngUserID = rsSource!user_id strDates = Nz(rsSource!DateList, "") If Len(strDates) > 0 Then arrDates = Split(strDates, " | ") For i = LBound(arrDates) To UBound(arrDates) If IsDate(arrDates(i)) Then rsTemp.AddNew rsTemp!user_id = lngUserID rsTemp!SingleDate = CDate(arrDates(i)) rsTemp.Update End If Next i End If rsSource.MoveNext Loop rsSource.Close Set rsSource = Nothing Set db = Nothing If Not rsTemp.EOF Then rsTemp.MoveFirst Set GetSplitDatesRecordset = rsTemp End Function Public Sub LoadDatesIntoForm(frm As Object) Dim rs As Object Set rs = GetSplitDatesRecordset() If rs.EOF Then MsgBox "لا توجد تواريخ!", vbExclamation Exit Sub End If If TypeOf frm Is Form Then Set frm.Recordset = rs ElseIf TypeOf frm Is Access.SubForm Then Set frm.Form.Recordset = rs End If End Sub Public Sub LoadDatesIntoListBox(frm As Form, strListBoxName As String) Dim rs As Object Dim strRowSource As String Dim ctl As Control Set ctl = frm.Controls(strListBoxName) Set rs = GetSplitDatesRecordset() If rs.EOF Then ctl.RowSource = "" Exit Sub End If Do Until rs.EOF strRowSource = strRowSource & rs!user_id & ";" & Format(rs!SingleDate, "yyyy-mm-dd") & ";" rs.MoveNext Loop ctl.RowSourceType = "Value List" ctl.ColumnCount = 2 ctl.ColumnWidths = "2cm;3cm" ctl.RowSource = strRowSource End Sub ولكن تعتمد على احدى الحيلتين الاولة نموذج مستمر غير منضم به حقلين الاول : txtuserId الثانى: txtSingleDate وعند تحمل النموذج نستخدم الاستدعاء التالى Private Sub Form_Load() Me.txtuserId.ControlSource = "user_id" Me.txtSingleDate.ControlSource = "SingleDate" LoadDatesIntoForm Me End Sub الحيلة الثانية نموذج غير منضم به مربع قيم مثلا باسم : lstDates وعند تحمل النموذج نستخدم الاستدعاء التالى Private Sub Form_Load() LoadDatesIntoListBox Me, "lstDates" End Sub هذا كل ما خطر على بالى من افكار

اذا الموضوع اسهل الان بوجود هذا الجدول المساعد مباشرة وبدون اى اكواد ممكن عمل الاستعلام التالى SELECT tbl1.user_id, tbl2.dateField FROM tbl1, tbl2 WHERE (((tbl2.dateField) Between [tbl1].[startA] And [tbl1].[endA])) ORDER BY tbl1.user_id, tbl2.dateField; ممكن الجدول المساعد tbl2 يتم عمل البيانات بداخله ديناميكا ليحتوى على كل تواريخ العام منذ بداية العام الى نهايته مثلا من خلال الكود التالى Public Sub PopulateDateTable(Optional ByVal dtmStartDate As Date = 0, Optional ByVal dtmEndDate As Date = 0) Dim db As DAO.Database Dim rs As DAO.Recordset Dim dtmDate As Date Dim lngYearNow As Long ' الحصول على السنة الحالية lngYearNow = Year(Date) ' تعيين القيم الافتراضية إذا لم يتم تمريرها If dtmStartDate = 0 Then dtmStartDate = DateSerial(lngYearNow, 1, 1) If dtmEndDate = 0 Then dtmEndDate = DateSerial(lngYearNow, 12, 31) ' التأكد أن التاريخين صالحين If dtmStartDate > dtmEndDate Then MsgBox "تاريخ البداية أكبر من تاريخ النهاية!", vbExclamation Exit Sub End If Set db = CurrentDb ' مسح البيانات القديمة db.Execute "DELETE FROM tbl2", dbFailOnError ' فتح الجدول للإضافة Set rs = db.OpenRecordset("tbl2", dbOpenDynaset) ' ملء السجلات For dtmDate = dtmStartDate To dtmEndDate rs.AddNew rs!dateField = dtmDate rs.Update Next dtmDate ' تنظيف الموارد rs.Close Set rs = Nothing Set db = Nothing MsgBox "تم توليد التواريخ من " & Format(dtmStartDate, "yyyy-mm-dd") & " إلى " & Format(dtmEndDate, "yyyy-mm-dd"), vbInformation End Sub

برضو بدون جداول ؟؟؟

وعليكم السلام ورحنة الله تعالى وبركاته ممكن من خلال الكود التالى فى وحده نمطية عامة مثلا باسم : basGetDatesBetween Public Function GetDatesBetween(ByVal dtmStartDate As Date, ByVal dtmEndDate As Date) As String If dtmStartDate > dtmEndDate Then GetDatesBetween = "" Exit Function End If Dim dtmCurrentDate As Date Dim arrDates() As String ReDim arrDates(0 To DateDiff("d", dtmStartDate, dtmEndDate)) Dim lngIndex As Long For dtmCurrentDate = dtmStartDate To dtmEndDate arrDates(lngIndex) = Format(dtmCurrentDate, "yyyy-mm-dd") lngIndex = lngIndex + 1 Next dtmCurrentDate GetDatesBetween = Join(arrDates, " | ") End Function على ان يكون الاستدعاء فى الاستعلام لعمل حقل التواريخ بالشكل التالى DateList: GetDatesBetween([startA],[endA]) لتكون جملة الاستعلام كاملة كما يلى SELECT tbl1.user_id, GetDatesBetween([startA], [endA]) AS DateList FROM tbl1; ويمكن خفظ الاستعلام مثلا باسم : qryUserDateList لا اعرف هل الفكرة تلبى الطلب ام لا خطر على بالى ايضا اضفة استعلام جديد يعتمد على الاستعلام السابق لنعط مثلا للاستعلام الجديد اسم : qryFilteredDates وتكون جملة الاستعلام بالشكل التالى SELECT * FROM qryUserDateList WHERE DateList LIKE "*" & Format([InbutFromDate], "yyyy-mm-dd") & "*" OR DateList LIKE "*" & Format([InbutToDate], "yyyy-mm-dd") & "*"; أو مثلا لو أردنا تمرير التواريخ من نموذج SELECT * FROM qryUserDateList WHERE DateList LIKE "*" & Format(Forms!frmSearch!txtFromDate, "yyyy-mm-dd") & "*" OR DateList LIKE "*" & Format(Forms!frmSearch!txtToDate, "yyyy-mm-dd") & "*"; وظيفة الاستعلام الاخير qryFilteredDates أذا كنا نريد البحث في DateList إن كانت تحتوي على أي تاريخ بين النطاقين وذلك لأنه لا يمكن تصفية نتيجة دالة GetDatesBetween بشكل مباشر باستخدام WHERE

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

حلو جدا دمج فكرة الاستاذ @منتصر الانسي Option Compare Database Option Explicit ' ===== متغير عام لتفعيل الطباعة في نافذة Immediate ===== Public DebugMod As Boolean ' =============================================== ' دالة رئيسية: تقوم بعملية DLookup مع دعم المعايير المتعددة ' =============================================== Public Function GenericDLookup( _ ByVal strFieldName As String, _ ByVal strTableName As String, _ ParamArray arrCriteria() As Variant) As Variant On Error GoTo ErrHandler Dim strCriteria As String Dim lngIndex As Long Dim strField As String, strOperator As String Dim varValue As Variant Dim strOneCondition As String Dim db As DAO.Database: Set db = CurrentDb Dim tdf As DAO.TableDef: Set tdf = db.TableDefs(strTableName) ' التحقق من وجود الجدول والحقل الأساسي If Not TableExists(strTableName, db) Then Err.Raise vbObjectError + 517, , "الجدول غير موجود: " & strTableName If Not FieldExists(strFieldName, tdf) Then Err.Raise vbObjectError + 518, , "الحقل غير موجود: " & strFieldName ' التحقق من شكل المصفوفة If (UBound(arrCriteria) + 1) Mod 3 <> 0 Then Err.Raise vbObjectError + 514, , "المعايير يجب أن تكون ثلاثية" For lngIndex = 0 To UBound(arrCriteria) Step 3 strField = CStr(arrCriteria(lngIndex)) strOperator = Trim(UCase(CStr(arrCriteria(lngIndex + 1)))) varValue = arrCriteria(lngIndex + 2) If Not FieldExists(strField, tdf) Then Err.Raise vbObjectError + 519, , "الحقل غير موجود: " & strField Select Case strOperator Case "IS NULL", "IS NOT NULL" strOneCondition = "[" & strField & "] " & strOperator Case "LIKE", "=", "<>", "<", ">", "<=", ">=" strOneCondition = "[" & strField & "] " & strOperator & " " & cSQLSafe(strTableName, strField, varValue, db, tdf) Case "BETWEEN" If IsArray(varValue) And UBound(varValue) = 1 Then strOneCondition = "[" & strField & "] BETWEEN " & _ cSQLSafe(strTableName, strField, varValue(0), db, tdf) & " AND " & _ cSQLSafe(strTableName, strField, varValue(1), db, tdf) Else Err.Raise vbObjectError + 520, , "القيمة لـ BETWEEN يجب أن تكون مصفوفة من عنصرين" End If Case "IN" If IsArray(varValue) Then Dim i As Long, strIN As String For i = LBound(varValue) To UBound(varValue) strIN = strIN & IIf(Len(strIN) > 0, ", ", "") & cSQLSafe(strTableName, strField, varValue(i), db, tdf) Next strOneCondition = "[" & strField & "] IN (" & strIN & ")" Else strOneCondition = "[" & strField & "] = " & cSQLSafe(strTableName, strField, varValue, db, tdf) End If Case "EXISTS" strOneCondition = "EXISTS (" & varValue & ")" Case Else Err.Raise vbObjectError + 515, , "المعامل غير مدعوم: " & strOperator End Select If Len(strCriteria) > 0 Then strCriteria = strCriteria & " AND " strCriteria = strCriteria & strOneCondition Next If DebugMod Then Debug.Print "GenericDLookup Criteria: " & strCriteria GenericDLookup = DLookup(strFieldName, strTableName, strCriteria) Exit Function ErrHandler: If DebugMod Then Debug.Print "خطأ في GenericDLookup: " & Err.Number & " - " & Err.Description GenericDLookup = Null End Function ' =============================================== ' التحقق من وجود الجدول ' =============================================== Private Function TableExists(TableName As String, db As DAO.Database) As Boolean On Error Resume Next Dim tdf As DAO.TableDef: Set tdf = db.TableDefs(TableName) TableExists = Not tdf Is Nothing On Error GoTo 0 End Function ' =============================================== ' التحقق من وجود الحقل داخل الجدول ' =============================================== Private Function FieldExists(FieldName As String, tdf As DAO.TableDef) As Boolean On Error Resume Next Dim fld As DAO.Field: Set fld = tdf.Fields(FieldName) FieldExists = Not fld Is Nothing On Error GoTo 0 End Function ' =============================================== ' تنسيق القيمة حسب نوع الحقل لاستخدامها داخل SQL ' =============================================== Public Function cSQLSafe(strTable As String, strField As String, varValue As Variant, _ Optional db As DAO.Database = Nothing, Optional tdf As DAO.TableDef = Nothing) As String On Error GoTo HandleError If db Is Nothing Then Set db = CurrentDb If tdf Is Nothing Then Set tdf = db.TableDefs(strTable) Dim fld As DAO.Field: Set fld = tdf.Fields(strField) Dim intType As Integer: intType = fld.Type If IsNull(varValue) Then cSQLSafe = "NULL": Exit Function Select Case intType Case dbText, dbMemo, dbGUID cSQLSafe = "'" & Replace(CStr(varValue), "'", "''") & "'" Case dbDate Dim dtm As Date If TryParseAnyDate(varValue, dtm) Then cSQLSafe = "#" & Format(dtm, IIf(TimeValue(dtm) = 0, "yyyy-mm-dd", "yyyy-mm-dd hh:nn:ss")) & "#" Else cSQLSafe = "NULL" End If Case dbBoolean cSQLSafe = IIf(varValue, "-1", "0") Case dbByte, dbInteger, dbLong, dbSingle, dbDouble, dbCurrency, dbDecimal If IsNumeric(varValue) Then cSQLSafe = Replace(Format(CDbl(varValue), "0.########"), ",", ".") Else cSQLSafe = "NULL" End If Case Else cSQLSafe = "NULL" End Select Exit Function HandleError: If DebugMod Then Debug.Print "[cSQLSafe] خطأ: " & Err.Number & " - " & Err.Description cSQLSafe = "NULL" End Function ' =============================================== ' دالة تحويل أي تنسيق تاريخ إلى قيمة صالحة ' =============================================== Public Function TryParseAnyDate(ByVal strInput As Variant, ByRef dtmOut As Date) As Boolean On Error GoTo Fail If IsNull(strInput) Then GoTo Fail If IsDate(strInput) Then dtmOut = CDate(strInput): TryParseAnyDate = True: Exit Function Dim parts() As String, dd As Integer, mm As Integer, yyyy As Integer Dim timePart As String, strClean As String strClean = Trim(CStr(strInput)) If InStr(strClean, " ") > 0 Then parts = Split(strClean, " ") strClean = parts(0) If UBound(parts) > 0 Then timePart = parts(1) End If strClean = Replace(Replace(strClean, "/", "."), "-", ".") parts = Split(strClean, ".") If UBound(parts) = 2 Then dd = Val(parts(0)): mm = Val(parts(1)): yyyy = Val(parts(2)) If yyyy < 100 Then yyyy = yyyy + IIf(yyyy < 30, 2000, 1900) If mm > 12 Then Dim tmp As Integer tmp = dd dd = mm mm = tmp End If If IsDate(DateSerial(yyyy, mm, dd)) Then dtmOut = DateSerial(yyyy, mm, dd) If Len(timePart) > 0 And IsDate(timePart) Then dtmOut = dtmOut + TimeValue(timePart) TryParseAnyDate = True Exit Function End If End If Fail: TryParseAnyDate = False End Function الاستدعاء Dim varResult As Variant varResult = GenericDLookup("date2", "tbl2", _ "date2", "=", Me.text1, _ "usr_id", "=", Me.text2 _ ) If IsNull(varResult) Then MsgBox "لا توجد نتيجة" Else MsgBox varResult End If

اذا السؤال الان هل لو الاستعلام معقد ويعالج العديد من البيانات اذا تتم المعالجة مع كل دفعة اذا الافضل مع هذه الحالات محاولة التحايل بطريقة ما لتحميل البيانات دفعة واحدة لتطبيق كافة العمليات

جزاكم الله خيـــــــــرا استاذى والان تعلمت شئ جديد وتم تصحيح معلومة مغلوطة لدى

مع التجربة عندما افتح الاستعلام واغلقه سريعا فقط يكون العدد 37 سجل فى الجدول الجديد ولو فتحت الاستعلام وانتظرت ثوان اكثر من ذى قبل يكون 64 تقريبا هذا يعني أن الاكسس كان يعالج باقي السجلات تدريجيا فقط في الخلفية رغم أنه تم فتح الاستعلام فقط ولم احاول استعراض اى عدد من السجلات

بعد اذن استاذى الجليل و معلمى القدير تجربة عملية: أضف Debug.Print ID داخل دالة Add_One افتح الاستعلام ولا تعرض سجلات اخرى افتح محرر الاكواد وانظر الى النتيجة تجد انه تم معالجة كل البيانات دفعة واحده تجربة عملية رقم (2) اعتذر عندى مشكلة لا استطيع اضافة اى مرفقات من فضلك قك بانشاء جدولا من خلال الاستعلام التالى CREATE TABLE tblFunctionCalls ( ID AUTOINCREMENT PRIMARY KEY, FunctionName TEXT(50), CallTime DATETIME, Param1 DOUBLE, Param2 DOUBLE, ResultValue DOUBLE, ContextInfo TEXT(100) ); انظر الى الكود التالى بتعديل بسيط Public Function Add_One(lngID As Long, dblN As Double) As Double Dim dblResult As Double dblResult = dblN + 1.5 If lngID = 55 Then dblResult = 55 End If ' تسجيل الاستدعاء في الجدول On Error Resume Next CurrentDb.Execute "INSERT INTO tblFunctionCalls (FunctionName, CallTime, Param1, Param2, ResultValue, ContextInfo) " & _ "VALUES ('Add_One', Now(), " & lngID & ", " & dblN & ", " & dblResult & ", '" & Nz(Application.CurrentObjectName, "Unknown") & "')" On Error GoTo 0 Add_One = dblResult End Function الان قم بفتح الاستعلام ولا تحرك الشاشة ولا تعرض اى سجلات اغلق الاستعلام انظر الى الجدول

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

انا عجبتنى الافكار بس اضفت بعض البهارات للطبخة اتمنى لكم مذاقا هنيئا Option Compare Database Option Explicit Public DebugMode As Boolean Public Sub ExportImagesToPdf( _ Optional blnShowImageNames As Boolean = True, _ Optional blnAddPageNumbers As Boolean = True, _ Optional strPdfName As String = "", _ Optional strFolderSource As String = "", _ Optional strFolderTarget As String = "" _ ) Dim strPdfPath As String Dim objFSO As Object, objFolder As Object, objFile As Object Dim objWordApp As Object, objDoc As Object, objRange As Object, objImg As Object Dim colFiles As Collection, arrFiles() As String Dim lngImgCount As Long, i As Long Dim fd As Object On Error GoTo ErrHandler ' اختيار مجلد الصور إذا لم يُمرر If Trim(strFolderSource) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد الذي يحتوي على الصور" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الصور." Exit Sub End If strFolderSource = .SelectedItems(1) End With End If If Right(strFolderSource, 1) <> "\" Then strFolderSource = strFolderSource & "\" If DebugMode Then Debug.Print "مجلد الصور: " & strFolderSource ' التحقق من وجود مجلد الصور If Dir(strFolderSource, vbDirectory) = "" Then MsgBox "مجلد الصور غير موجود", vbCritical + vbMsgBoxRight Exit Sub End If ' اختيار مجلد الهدف إذا لم يُمرر If Trim(strFolderTarget) = "" Then Set fd = Application.FileDialog(4) With fd .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then If DebugMode Then Debug.Print "تم إلغاء اختيار مجلد الهدف." Exit Sub End If strFolderTarget = .SelectedItems(1) End With End If If Right(strFolderTarget, 1) <> "\" Then strFolderTarget = strFolderTarget & "\" If Dir(strFolderTarget, vbDirectory) = "" Then MkDir strFolderTarget If DebugMode Then Debug.Print "تم إنشاء مجلد الهدف: " & strFolderTarget End If ' إعداد اسم ملف PDF If Trim(strPdfName) = "" Then strPdfPath = strFolderTarget & "صور_المجلد_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".pdf" Else strPdfPath = strFolderTarget & strPdfName & ".pdf" End If If DebugMode Then Debug.Print "مسار ملف PDF: " & strPdfPath ' جمع الصور Set colFiles = New Collection Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strFolderSource) For Each objFile In objFolder.Files If LCase(objFile.Name) Like "*.jpg" Or LCase(objFile.Name) Like "*.jpeg" Or _ LCase(objFile.Name) Like "*.png" Or LCase(objFile.Name) Like "*.bmp" Or _ LCase(objFile.Name) Like "*.gif" Then colFiles.Add objFile.Path lngImgCount = lngImgCount + 1 If DebugMode Then Debug.Print "تم العثور على صورة: " & objFile.Path End If Next If lngImgCount = 0 Then MsgBox "لا توجد صور في المجلد المحدد", vbExclamation + vbMsgBoxRight GoTo CleanExit End If ' تحويل الـ Collection إلى مصفوفة ReDim arrFiles(0 To lngImgCount - 1) For i = 1 To colFiles.Count arrFiles(i - 1) = colFiles(i) Next ' فرز الصور Call SortArray(arrFiles) If DebugMode Then Debug.Print "تم فرز الصور" ' إنشاء مستند Word Set objWordApp = CreateObject("Word.Application") Set objDoc = objWordApp.Documents.Add objWordApp.Visible = False With objDoc.PageSetup .Orientation = 0 .TopMargin = 28 .BottomMargin = 28 .LeftMargin = 28 .RightMargin = 28 End With ' إضافة ترقيم الصفحات (إذا تم اختياره) If blnAddPageNumbers Then With objDoc.Sections(1).Footers(1).PageNumbers .Add 1, True .NumberStyle = 0 ' wdNumberStyleArabic With .Parent.Range .ParagraphFormat.Alignment = 1 ' توسيط .Font.Size = 8 .Font.Color = RGB(100, 100, 100) End With End With End If ' إدراج الصور For i = 0 To UBound(arrFiles) Set objRange = objDoc.Range objRange.Collapse 0 If i > 0 Then objRange.InsertBreak 2 objRange.Collapse 0 End If ' إدراج الصورة objRange.ParagraphFormat.Alignment = 1 Set objImg = objRange.InlineShapes.AddPicture(arrFiles(i), False, True) With objImg .LockAspectRatio = True If .Width > 500 Or .Height > 650 Then If .Width / .Height > 500 / 650 Then .Width = 500 Else .Height = 650 End If End If End With ' إضافة اسم الملف أسفل الصورة (إذا تم اختياره) If blnShowImageNames Then Set objRange = objDoc.Range objRange.Collapse 0 objRange.InsertAfter vbCrLf & Mid(arrFiles(i), InStrRev(arrFiles(i), "\") + 1) With objRange .ParagraphFormat.Alignment = 1 .ParagraphFormat.SpaceAfter = 6 .Font.Size = 9 .Font.Color = RGB(120, 120, 120) End With End If If DebugMode Then Debug.Print "تم إدراج الصورة: " & arrFiles(i) Next ' حذف أي فقرات فارغة في بداية المستند While objDoc.Paragraphs.Count > 0 And Trim(objDoc.Paragraphs(1).Range.Text) = "" objDoc.Paragraphs(1).Range.Delete Wend ' حذف فقرة فارغة محتملة في النهاية If objDoc.Paragraphs.Count > 0 Then With objDoc.Paragraphs(objDoc.Paragraphs.Count).Range If Trim(.Text) = "" Then .Delete End With End If ' حفظ كـ PDF objDoc.SaveAs2 strPdfPath, 17 objDoc.Close False objWordApp.Quit MsgBox "تم إنشاء ملف PDF بنجاح:" & vbCrLf & strPdfPath, vbInformation + vbMsgBoxRight CleanExit: Set objDoc = Nothing Set objWordApp = Nothing Set objRange = Nothing Set objImg = Nothing Set colFiles = Nothing Set objFolder = Nothing Set objFSO = Nothing Set fd = Nothing Exit Sub ErrHandler: If DebugMode Then Debug.Print "خطأ: " & Err.Number & " - " & Err.Description End If MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight Resume CleanExit End Sub Private Sub SortArray(ByRef arr() As String) Dim i As Long, j As Long Dim temp As String For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If UCase(arr(i)) > UCase(arr(j)) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub

وتوضيحا فقط وحسب فهمى لقول استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ جعفر - الاكسس يعالج فقط السجلات المعروضة على الشاشة (مثلا 30)؟ صحيح فقط في حالة النماذج (Forms) وغير صحيح في حالة فتح الاستعلام مباشرة أو في التقارير أو التصدير الاكسس ينفذ الاستعلام بالكامل ويحسب النتائج لكل السجلات - إذا كان الاستعلام مصدرا لنموذج فلن يكون هناك بطء ملحوظ؟ صحيح إذا لم تستخدم دوال خارجية في حقول يتم عليها فرز/تصفية لو كان هناك: فرز أو تصفية على حقل فيه دالة DLookup أو دالة VBA خارجية أو تحميل بيانات من جدول كبير بدون فهرسة مناسبة - الطباعة لا تسبب بطء لأنها تطبع صفحة صفحة؟ غير دقيق: الاكسس يقوم بتجهيز التقرير بالكامل قبل عرض أول صفحة أي دوال خارجية أو معادلات تحسب على كل السجلات قبل العرض والطباعة - لا يوجد بطء عند استخدام دوال خارجية إذا لم تكن هناك عمليات فرز أو تصفية؟ صحيح تماما في حالة: استخدام الاستعلام كمصدر نموذج أو عرض النتائج فقط دون فرز/تصفية على الحقول التي تنادي دوال خارجية لكن عند فتح الاستعلام مباشرة أو فرز/تصفية الحقول المحسوبة الاكسس يجبر على حساب القيم لكل السجلات ردودى السابقة لتحليل فهمى لمشاركة الاستاذ جعفر حسب فهمى ومعلوماتى الشخصية وان كان فهمى خاطى أنتظر التصحيح من اساتذتى العظماء

الاكسس يقوم بحساب السجلات المعروضة على الشاشة فقط عندما يكون ذلك داخل نموذج وليس داخل استعلام هذا حسب فهمى المتواضع قد اكون مخطئ. ربما هذا الظاهر فقط الان ولكن انا دائما مع الاستعلامات اعمل وفق هذه القاعدة الذهبية دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية عند فتح استعلام مباشرة (Query View أو من الكود) Access يقوم بتحميل كل السجلات دفعة واحدة وليس فقط الظاهرة على الشاشة يعني: سواء كان عندك 100 أو 1000,000 سجل وسواء كان حجم الشاشة يعرض 30 فقط او حتى 10 بمجرد فتح الاستعلام مباشرة (من نافذة Access أو من الكود) يقوم Access بتنفيذ الاستعلام بالكامل من البداية إلى النهاية ويحسب ويقوم بمعالجة البيانات فى كل الأعمدة بما فيها الدوال مثل DLookup أو أي دوال خارجية ثم يظهر أول 30 سجل فقط او اول 10 سجلات حسب حجم الشاشة لكن المعالجة تمت لكل السجلات بالفعل

السلام عليكم طبعا وبادئ ذى بدئ اخى موسي فوق راسي وردى التالى ليس تقليلا او شئ من هذا القبيل اطلاقا ولكن فقط هذه وجهة نظرى قد اكون محطئ فيها وقد أصيب احل اخى موسي يبدو الطف فى الشكل الظاهرى ولكن ليس بالضرورة أخف تعتمد طريقة اخى موسى على انشاء سلسلة نصية و معالجة النص باستخدام (InStr وIIf) مما قد يكون بطئ نسبيا مع مرور الوقت وبالأخص مع وجود بيانات كبيرة بينما تعتمد طريقتى المتواضعة على استخدام شروط منطقية صريحة (AND - OR - NOT) والتى بدورها سوف تكون اسرع مع محرك الاستعلام لان التحقق يتم على القيم مباشرة دون تكوين سلاسل أو بحث نصي قاعدة ذهبيه مع الاستعلامات : دائما الأولوية للمنطق المباشر أفضل من الاعتماد على الحيل النصية

SELECT tblNames.UserId, tblNames.s_name, tblDays.day_id, tblDays.dayNm FROM tblDays, tblNames WHERE tblNames.UserId = [Forms]![Form1]![Combo0] AND ( (tblDays.day_id = 1 AND NOT tblNames.chekVuc1) OR (tblDays.day_id = 2 AND NOT tblNames.chekVuc2) OR (tblDays.day_id = 3 AND NOT tblNames.chekVuc3) OR (tblDays.day_id = 4 AND NOT tblNames.chekVuc4) OR (tblDays.day_id = 5 AND NOT tblNames.chekVuc5) OR (tblDays.day_id = 6 AND NOT tblNames.chekVuc6) OR (tblDays.day_id = 7 AND NOT tblNames.chekVuc7) ); اعتذر عندى مشكلة بالانترنت لا استطيع رفع مرفقات استاذى الجليل ومعلمى القدير و والدى الحبيب لا اعرف هل الافكار فى هذا الموضوع مشابهه ام تساعد فى تحقيق اى من اهدافكم الحالية او المستقبلية ام لا ولكن احسست بوجه شبه من بعيد او من قريب بينهم

Public Function MultiplyTime(strTime As String, factor As Double) As String On Error GoTo ErrHandler Dim totalMinutes As Double totalMinutes = TimeValue(strTime) * 24 * 60 * factor MultiplyTime = Format(totalMinutes / 24 / 60, "hh:nn") Exit Function ErrHandler: MultiplyTime = "خطأ في الوقت" End Function وللاستدعاء MultiplyTime("4:30", 5)

وانا باستخدم الكود ده فى وحده نمطية عامة Option Compare Database Option Explicit Public DebugMod As Boolean Public Function GenericDLookupPro( _ ByVal strFieldName As String, _ ByVal strTableName As String, _ ParamArray arrCriteria() As Variant) As Variant Dim strCriteria As String Dim lngIndex As Long Dim strField As String Dim strOperator As String Dim varValue As Variant Dim strOneCondition As String Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim intFieldType As Integer On Error GoTo ErrHandler Set db = CurrentDb ' تحقق من وجود الجدول أولًا If Not TableExists(strTableName, db) Then Err.Raise vbObjectError + 517, , "الجدول غير موجود: " & strTableName End If Set tdf = db.TableDefs(strTableName) ' تحقق من وجود الحقل المطلوب إرجاعه If Not FieldExists(strFieldName, tdf) Then Err.Raise vbObjectError + 518, , "الحقل غير موجود: " & strFieldName End If ' تأكد أن عدد عناصر المعايير من مضاعفات 3 If (UBound(arrCriteria) - lngIndex + 1) Mod 3 <> 0 Then Err.Raise vbObjectError + 514, , "يجب أن تكون المعايير على شكل ثلاثي: (الحقل، المعامل، القيمة)" End If Do While lngIndex <= UBound(arrCriteria) strField = CStr(arrCriteria(lngIndex)) If IsNull(arrCriteria(lngIndex + 1)) Then Err.Raise vbObjectError + 516, , "المعامل لا يمكن أن يكون Null" Else strOperator = Trim(UCase(CStr(arrCriteria(lngIndex + 1)))) End If varValue = arrCriteria(lngIndex + 2) ' التحقق من وجود الحقل If Not FieldExists(strField, tdf) Then Err.Raise vbObjectError + 519, , "الحقل '" & strField & "' غير موجود في الجدول '" & strTableName & "'" End If Set fld = tdf.Fields(strField) intFieldType = fld.Type ' بناء الشرط Select Case strOperator Case "IS NULL", "IS NOT NULL" strOneCondition = "[" & strField & "] " & strOperator Case "LIKE" strOneCondition = "[" & strField & "] LIKE '" & Replace(Nz(varValue, ""), "'", "''") & "'" Case "=", "<>", ">", "<", ">=", "<=" Select Case True Case IsNull(varValue) strOneCondition = "[" & strField & "] IS NULL" Case IsEmpty(varValue) Or varValue = "" strOneCondition = "[" & strField & "] = ''" Case intFieldType = dbText Or intFieldType = dbMemo Or intFieldType = dbGUID strOneCondition = "[" & strField & "] " & strOperator & " '" & Replace(CStr(varValue), "'", "''") & "'" Case intFieldType = dbDate strOneCondition = "[" & strField & "] " & strOperator & " #" & Format(CDate(varValue), "mm\/dd\/yyyy") & "#" Case Else strOneCondition = "[" & strField & "] " & strOperator & " " & varValue End Select Case Else Err.Raise vbObjectError + 515, , "المعامل غير مدعوم: " & strOperator End Select ' دمج الشرط If Len(strCriteria) > 0 Then strCriteria = strCriteria & " AND " strCriteria = strCriteria & strOneCondition lngIndex = lngIndex + 3 Loop If DebugMod Then Debug.Print "DLookup Criteria: " & strCriteria GenericDLookupPro = Nz(DLookup(strFieldName, strTableName, strCriteria), "لم يتم العثور على بيانات") CleanExit: Set fld = Nothing Set tdf = Nothing Set db = Nothing Exit Function ErrHandler: If DebugMod Then Debug.Print "خطأ في GenericDLookupPro: " & Err.Description GenericDLookupPro = Null Resume CleanExit End Function Private Function TableExists(TableName As String, db As DAO.Database) As Boolean Dim tdf As DAO.TableDef On Error Resume Next Set tdf = db.TableDefs(TableName) TableExists = Not tdf Is Nothing On Error GoTo 0 End Function Private Function FieldExists(FieldName As String, tdf As DAO.TableDef) As Boolean Dim fld As DAO.Field On Error Resume Next Set fld = tdf.Fields(FieldName) FieldExists = Not fld Is Nothing On Error GoTo 0 End Function ممكن حضرتك تجربه ليتم الاستدعاء من خلاله بالشكل التالى DebugMod = True Dim varResult As Variant varResult = GenericDLookupPro("date2", "tbl2", "date2", "=", Me.text1, "usr_id", "=", Me.text2) MsgBox varResult مرونة تامة في كتابة المعايير بصيغة: (اسم الحقل، المعامل، القيمة) دعم كامل للمعاملات: =, <>, >, <, >=, <=, LIKE, IS NULL, IS NOT NULL تحقق تلقائي من وجود الجدول والحقل تحليل ذكي لنوع الحقل (نصي، تاريخ، رقمي...) وبناء الشرط المناسب تلقائيا آمن ضد القيم الفارغة (Null, Empty, "") تتبع اختياري للتنفيذ في نافذة Immediate باستخدام DebugMod عند الحاجة الى التتبع والطباعة

السلام عليكم ورحمة الله تعالى وبركاته استاذى الجليل ومعلمى القدير و والدى الحبيب ممكن حضرتك تجرب الكود ده Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String sql = "SELECT [date2] FROM tbl2 WHERE [date2] = #" & Format(Me.text1, "mm\/dd\/yyyy") & "# AND [usr_id] = '" & Me.text2 & "'" Debug.Print sql Set db = CurrentDb Set rs = db.OpenRecordset(sql) If Not rs.EOF Then MsgBox rs![date2] Else MsgBox "لم يتم العثور على بيانات" End If rs.Close Set rs = Nothing Set db = Nothing أو Dim i As Variant i = DLookup("[date2]", "tbl2", "[date2] = #" & Format(Me.text1, "mm\/dd\/yyyy") & "# AND [usr_id] = '" & Me.text2 & "'") If IsNull(i) Then MsgBox "لم يتم العثور على بيانات" Else MsgBox i End If

فى انتظار المرفق ان شاء الله بعد انتهائك من تجميع الافكار وفق فكرتك العبقرية

ادامك الله فوق رؤسنا وحفظكم لنا ولأحبابكم الحمد لله الذى تتم بنعمته الصالحات

السلام عليكم استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممتاز الان اتضحت لى الفكرة تمام انا كانت فكرتى ان لا اقوم بتعديل الاعدادت داخل كافة النماذج ولكن فقط تطبيق الاعدادت الجديدة مع الاحتفاظ بالوضع الاصلى عند التصميم ولكن حضرتك تريد فتح كافة النماذج فى وضع التصميم وتطبيق كل التعديلات على كافة النماذج لخدمة المصمم وطامل انها لخدمة المصمم فقط وتريد كل الاكواد فى النموذج دون الاعتماد على وحدات نمطية ليسهل استخدام النموذج وما بجعبته مع اى قاعدة أخرى بمجرد نسخه اليها لقد قمت بكتابة الكود بالشكل التالى : Option Compare Database Option Explicit '' ======= التصريحات والثوابت #If VBA7 Then Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long #Else Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long #End If #If VBA7 Then Private Type CHOOSECOLOR lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr rgbResult As Long lpCustColors As LongPtr Flags As Long lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As LongPtr End Type #Else Private Type CHOOSECOLOR lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long Flags As Long lCustData As Long lpfnHook As Long lpTemplateName As Long End Type #End If Private Enum SectionType stHeader = acHeader stDetail = acDetail stFooter = acFooter End Enum Private Enum ControlType ctTextBox = acTextBox ctComboBox = acComboBox ctListBox = acListBox ctLabel = acLabel ctCommandButton = acCommandButton End Enum Private Const COLOR_UNSET As Long = -1 Private Const TABLE_NAME_THEME_SETTINGS As String = "tblThemeSettings" Private Const FIELD_NAME As String = "SettingName" Private Const FIELD_VALUE As String = "SettingValue" Private Theme As Object Private DebugMode As Boolean '' ======= إنشاء القاموس عند بدء التشغيل Private Sub InitializeThemeDictionary() Set Theme = CreateObject("Scripting.Dictionary") Theme.Add "Header", CreateObject("Scripting.Dictionary") Theme("Header").Add "SectionBack", COLOR_UNSET Theme("Header").Add "TextBack", COLOR_UNSET Theme("Header").Add "TextBorder", COLOR_UNSET Theme("Header").Add "TextFont", COLOR_UNSET Theme("Header").Add "LabelBack", COLOR_UNSET Theme("Header").Add "LabelBorder", COLOR_UNSET Theme("Header").Add "LabelFont", COLOR_UNSET Theme.Add "Detail", CreateObject("Scripting.Dictionary") Theme("Detail").Add "SectionBack", COLOR_UNSET Theme("Detail").Add "TextBack", COLOR_UNSET Theme("Detail").Add "TextBorder", COLOR_UNSET Theme("Detail").Add "TextFont", COLOR_UNSET Theme("Detail").Add "LabelBack", COLOR_UNSET Theme("Detail").Add "LabelBorder", COLOR_UNSET Theme("Detail").Add "LabelFont", COLOR_UNSET Theme.Add "Footer", CreateObject("Scripting.Dictionary") Theme("Footer").Add "SectionBack", COLOR_UNSET Theme("Footer").Add "TextBack", COLOR_UNSET Theme("Footer").Add "TextBorder", COLOR_UNSET Theme("Footer").Add "TextFont", COLOR_UNSET Theme("Footer").Add "LabelBack", COLOR_UNSET Theme("Footer").Add "LabelBorder", COLOR_UNSET Theme("Footer").Add "LabelFont", COLOR_UNSET Theme.Add "Button", CreateObject("Scripting.Dictionary") Theme("Button").Add "Back", COLOR_UNSET Theme("Button").Add "Border", COLOR_UNSET Theme("Button").Add "Font", COLOR_UNSET Theme("Button").Add "Hover", COLOR_UNSET Theme("Button").Add "Pressed", COLOR_UNSET Theme("Button").Add "HoverFore", COLOR_UNSET Theme("Button").Add "PressedFore", COLOR_UNSET Theme.Add "Combo", CreateObject("Scripting.Dictionary") Theme("Combo").Add "Back", COLOR_UNSET Theme("Combo").Add "Border", COLOR_UNSET Theme("Combo").Add "Font", COLOR_UNSET Theme.Add "List", CreateObject("Scripting.Dictionary") Theme("List").Add "Back", COLOR_UNSET Theme("List").Add "Border", COLOR_UNSET Theme("List").Add "Font", COLOR_UNSET End Sub '' ======= أحداث النموذج Private Sub Form_Load() InitializeThemeDictionary EnsureThemeTableExists LoadThemeFromTable End Sub Private Sub btnSaveAndApply_Click() SaveThemeToTable ApplyThemeToAllForms MsgBox "تم تطبيق الثيم بنجاح.", vbInformation End Sub Private Sub btnApplyDefaultThemeToCurrentForm_Click() SetDefaultThemeValues ApplyThemePreview End Sub '' ======= أزرار تغيير الألوان Private Sub btnHeaderSectionColor_Click() Dim lngColor As Long lngColor = Theme("Header")("SectionBack") ApplySectionColor lngColor, stHeader Theme("Header")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlBack_Click() Dim lngColor As Long lngColor = Theme("Header")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stHeader Theme("Header")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlBorder_Click() Dim lngColor As Long lngColor = Theme("Header")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stHeader Theme("Header")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderControlFore_Click() Dim lngColor As Long lngColor = Theme("Header")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stHeader Theme("Header")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelBack_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stHeader Theme("Header")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stHeader Theme("Header")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnHeaderLabelFore_Click() Dim lngColor As Long lngColor = Theme("Header")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stHeader Theme("Header")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnDetailSectionColor_Click() Dim lngColor As Long lngColor = Theme("Detail")("SectionBack") ApplySectionColor lngColor, stDetail Theme("Detail")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlBack_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stDetail Theme("Detail")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlBorder_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stDetail Theme("Detail")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnDetailControlFore_Click() Dim lngColor As Long lngColor = Theme("Detail")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stDetail Theme("Detail")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelBack_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stDetail Theme("Detail")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stDetail Theme("Detail")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnDetailLabelFore_Click() Dim lngColor As Long lngColor = Theme("Detail")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stDetail Theme("Detail")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnFooterSectionColor_Click() Dim lngColor As Long lngColor = Theme("Footer")("SectionBack") ApplySectionColor lngColor, stFooter Theme("Footer")("SectionBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlBack_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextBack") HandleColorPick lngColor, "BackColor", ctTextBox, stFooter Theme("Footer")("TextBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlBorder_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextBorder") HandleColorPick lngColor, "BorderColor", ctTextBox, stFooter Theme("Footer")("TextBorder") = lngColor ApplyThemePreview End Sub Private Sub btnFooterControlFore_Click() Dim lngColor As Long lngColor = Theme("Footer")("TextFont") HandleColorPick lngColor, "ForeColor", ctTextBox, stFooter Theme("Footer")("TextFont") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelBack_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelBack") HandleColorPick lngColor, "BackColor", ctLabel, stFooter Theme("Footer")("LabelBack") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelBorder_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelBorder") HandleColorPick lngColor, "BorderColor", ctLabel, stFooter Theme("Footer")("LabelBorder") = lngColor ApplyThemePreview End Sub Private Sub btnFooterLabelFore_Click() Dim lngColor As Long lngColor = Theme("Footer")("LabelFont") HandleColorPick lngColor, "ForeColor", ctLabel, stFooter Theme("Footer")("LabelFont") = lngColor ApplyThemePreview End Sub Private Sub btnCommandBack_Click() Dim lngColor As Long lngColor = Theme("Button")("Back") HandleColorPick lngColor, "BackColor", ctCommandButton Theme("Button")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnCommandBorder_Click() Dim lngColor As Long lngColor = Theme("Button")("Border") HandleColorPick lngColor, "BorderColor", ctCommandButton Theme("Button")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnCommandFore_Click() Dim lngColor As Long lngColor = Theme("Button")("Font") HandleColorPick lngColor, "ForeColor", ctCommandButton Theme("Button")("Font") = lngColor ApplyThemePreview End Sub Private Sub btnCommandHover_Click() Dim lngColor As Long lngColor = Theme("Button")("Hover") lngColor = PickColorFromBase(lngColor) Theme("Button")("Hover") = lngColor ApplyThemePreview End Sub Private Sub btnCommandPressed_Click() Dim lngColor As Long lngColor = Theme("Button")("Pressed") lngColor = PickColorFromBase(lngColor) Theme("Button")("Pressed") = lngColor ApplyThemePreview End Sub Private Sub btnCommandHoverFore_Click() Dim lngColor As Long lngColor = Theme("Button")("HoverFore") lngColor = PickColorFromBase(lngColor) Theme("Button")("HoverFore") = lngColor ApplyThemePreview End Sub Private Sub btnCommandPressedFore_Click() Dim lngColor As Long lngColor = Theme("Button")("PressedFore") lngColor = PickColorFromBase(lngColor) Theme("Button")("PressedFore") = lngColor ApplyThemePreview End Sub Private Sub btnComboBack_Click() Dim lngColor As Long lngColor = Theme("Combo")("Back") HandleColorPick lngColor, "BackColor", ctComboBox Theme("Combo")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnComboBorder_Click() Dim lngColor As Long lngColor = Theme("Combo")("Border") HandleColorPick lngColor, "BorderColor", ctComboBox Theme("Combo")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnComboFore_Click() Dim lngColor As Long lngColor = Theme("Combo")("Font") HandleColorPick lngColor, "ForeColor", ctComboBox Theme("Combo")("Font") = lngColor ApplyThemePreview End Sub Private Sub btnListBack_Click() Dim lngColor As Long lngColor = Theme("List")("Back") HandleColorPick lngColor, "BackColor", ctListBox Theme("List")("Back") = lngColor ApplyThemePreview End Sub Private Sub btnListBorder_Click() Dim lngColor As Long lngColor = Theme("List")("Border") HandleColorPick lngColor, "BorderColor", ctListBox Theme("List")("Border") = lngColor ApplyThemePreview End Sub Private Sub btnListFore_Click() Dim lngColor As Long lngColor = Theme("List")("Font") HandleColorPick lngColor, "ForeColor", ctListBox Theme("List")("Font") = lngColor ApplyThemePreview End Sub '' ======= قيم افتراضية Private Sub SetDefaultThemeValues() Theme("Header")("SectionBack") = RGB(230, 230, 250) Theme("Header")("TextBack") = RGB(255, 255, 255) Theme("Header")("TextBorder") = RGB(180, 180, 180) Theme("Header")("TextFont") = RGB(0, 0, 0) Theme("Header")("LabelBack") = RGB(240, 240, 240) Theme("Header")("LabelBorder") = RGB(240, 240, 240) Theme("Header")("LabelFont") = RGB(0, 0, 0) Theme("Detail")("SectionBack") = RGB(255, 255, 255) Theme("Detail")("TextBack") = RGB(255, 255, 255) Theme("Detail")("TextBorder") = RGB(180, 180, 180) Theme("Detail")("TextFont") = RGB(0, 0, 0) Theme("Detail")("LabelBack") = RGB(240, 240, 240) Theme("Detail")("LabelBorder") = RGB(240, 240, 240) Theme("Detail")("LabelFont") = RGB(0, 0, 0) Theme("Footer")("SectionBack") = RGB(245, 245, 245) Theme("Footer")("TextBack") = RGB(255, 255, 255) Theme("Footer")("TextBorder") = RGB(180, 180, 180) Theme("Footer")("TextFont") = RGB(0, 0, 0) Theme("Footer")("LabelBack") = RGB(240, 240, 240) Theme("Footer")("LabelBorder") = RGB(240, 240, 240) Theme("Footer")("LabelFont") = RGB(0, 0, 0) Theme("Button")("Back") = RGB(220, 220, 220) Theme("Button")("Border") = RGB(180, 180, 180) Theme("Button")("Font") = RGB(0, 0, 0) Theme("Button")("Hover") = RGB(200, 200, 255) Theme("Button")("Pressed") = RGB(150, 150, 220) Theme("Button")("HoverFore") = RGB(0, 0, 80) Theme("Button")("PressedFore") = RGB(255, 255, 255) Theme("Combo")("Back") = RGB(255, 255, 255) Theme("Combo")("Border") = RGB(160, 160, 160) Theme("Combo")("Font") = RGB(0, 0, 0) Theme("List")("Back") = RGB(255, 255, 255) Theme("List")("Border") = RGB(180, 180, 180) Theme("List")("Font") = RGB(0, 0, 0) End Sub '' ======= دوال مساعدة Private Function PickColorFromBase(Optional ByVal lngStartColor As Long = -1) As Long Dim cc As CHOOSECOLOR Dim aColors(15) As Long cc.lStructSize = LenB(cc) cc.hwndOwner = Application.hWndAccessApp cc.lpCustColors = VarPtr(aColors(0)) If lngStartColor <> -1 Then cc.rgbResult = lngStartColor cc.Flags = &H1 End If If CHOOSECOLOR(cc) Then PickColorFromBase = cc.rgbResult Else PickColorFromBase = COLOR_UNSET End If End Function Private Sub HandleColorPick(ByRef lngTargetVar As Long, ByVal strProperty As String, ByVal lngControlType As Long, Optional ByVal lngSection As Variant) Dim lngNewColor As Long Dim ctl As Control Dim bolMatchSection As Boolean lngNewColor = PickColorFromBase(lngTargetVar) If lngNewColor = COLOR_UNSET Then Exit Sub lngTargetVar = lngNewColor For Each ctl In Me.Controls If ctl.ControlType = lngControlType Then On Error Resume Next bolMatchSection = (IsMissing(lngSection) Or ctl.section = lngSection) On Error GoTo 0 If bolMatchSection Then On Error Resume Next CallByName ctl, strProperty, VbLet, lngNewColor On Error GoTo 0 End If End If Next ctl End Sub Private Sub ApplySectionColor(ByRef lngTargetVar As Long, ByVal lngSection As Long) Dim lngNewColor As Long lngNewColor = PickColorFromBase(lngTargetVar) If lngNewColor <> COLOR_UNSET Then lngTargetVar = lngNewColor Me.section(lngSection).BackColor = lngNewColor End If End Sub Private Sub ApplyThemePreview() Dim ctl As Control Dim sec As String If Theme("Header")("SectionBack") <> COLOR_UNSET Then Me.section(stHeader).BackColor = Theme("Header")("SectionBack") If Theme("Detail")("SectionBack") <> COLOR_UNSET Then Me.section(stDetail).BackColor = Theme("Detail")("SectionBack") If Theme("Footer")("SectionBack") <> COLOR_UNSET Then Me.section(stFooter).BackColor = Theme("Footer")("SectionBack") For Each ctl In Me.Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select If Theme(sec)("TextBack") <> COLOR_UNSET Then ctl.BackColor = Theme(sec)("TextBack") If Theme(sec)("TextBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(sec)("TextBorder") If Theme(sec)("TextFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(sec)("TextFont") Case ctComboBox If Theme("Combo")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Combo")("Back") If Theme("Combo")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Combo")("Border") If Theme("Combo")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Combo")("Font") Case ctListBox If Theme("List")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("List")("Back") If Theme("List")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("List")("Border") If Theme("List")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("List")("Font") Case ctLabel Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select If Theme(sec)("LabelBack") <> COLOR_UNSET Then ctl.BackColor = Theme(sec)("LabelBack") If Theme(sec)("LabelBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(sec)("LabelBorder") If Theme(sec)("LabelFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(sec)("LabelFont") Case ctCommandButton If Theme("Button")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Button")("Back") If Theme("Button")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Button")("Border") If Theme("Button")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Button")("Font") On Error Resume Next If Theme("Button")("Hover") <> COLOR_UNSET Then ctl.HoverColor = Theme("Button")("Hover") If Theme("Button")("Pressed") <> COLOR_UNSET Then ctl.PressedColor = Theme("Button")("Pressed") If Theme("Button")("HoverFore") <> COLOR_UNSET Then ctl.HoverForeColor = Theme("Button")("HoverFore") If Theme("Button")("PressedFore") <> COLOR_UNSET Then ctl.PressedForeColor = Theme("Button")("PressedFore") On Error GoTo 0 End Select NextControl: Next ctl End Sub Private Sub EnsureThemeTableExists() Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb On Error Resume Next Set tdf = db.TableDefs(TABLE_NAME_THEME_SETTINGS) On Error GoTo 0 If tdf Is Nothing Then db.Execute "CREATE TABLE " & TABLE_NAME_THEME_SETTINGS & " (" & _ FIELD_NAME & " TEXT(50) PRIMARY KEY, " & _ FIELD_VALUE & " LONG)", dbFailOnError End If End Sub Private Sub SaveColorSetting(ByRef rs As DAO.Recordset, ByVal strName As String, ByVal lngValue As Long) rs.FindFirst FIELD_NAME & "='" & strName & "'" If rs.NoMatch Then rs.AddNew rs(FIELD_NAME) = strName rs(FIELD_VALUE) = lngValue rs.Update ElseIf rs(FIELD_VALUE) <> lngValue Then rs.Edit rs(FIELD_VALUE) = lngValue rs.Update End If End Sub Private Sub SaveThemeToTable() Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset(TABLE_NAME_THEME_SETTINGS, dbOpenDynaset) SaveColorSetting rs, "Header_SectionBack", Theme("Header")("SectionBack") SaveColorSetting rs, "Header_TextBack", Theme("Header")("TextBack") SaveColorSetting rs, "Header_TextBorder", Theme("Header")("TextBorder") SaveColorSetting rs, "Header_TextFont", Theme("Header")("TextFont") SaveColorSetting rs, "Header_LabelBack", Theme("Header")("LabelBack") SaveColorSetting rs, "Header_LabelBorder", Theme("Header")("LabelBorder") SaveColorSetting rs, "Header_LabelFont", Theme("Header")("LabelFont") SaveColorSetting rs, "Detail_SectionBack", Theme("Detail")("SectionBack") SaveColorSetting rs, "Detail_TextBack", Theme("Detail")("TextBack") SaveColorSetting rs, "Detail_TextBorder", Theme("Detail")("TextBorder") SaveColorSetting rs, "Detail_TextFont", Theme("Detail")("TextFont") SaveColorSetting rs, "Detail_LabelBack", Theme("Detail")("LabelBack") SaveColorSetting rs, "Detail_LabelBorder", Theme("Detail")("LabelBorder") SaveColorSetting rs, "Detail_LabelFont", Theme("Detail")("LabelFont") SaveColorSetting rs, "Footer_SectionBack", Theme("Footer")("SectionBack") SaveColorSetting rs, "Footer_TextBack", Theme("Footer")("TextBack") SaveColorSetting rs, "Footer_TextBorder", Theme("Footer")("TextBorder") SaveColorSetting rs, "Footer_TextFont", Theme("Footer")("TextFont") SaveColorSetting rs, "Footer_LabelBack", Theme("Footer")("LabelBack") SaveColorSetting rs, "Footer_LabelBorder", Theme("Footer")("LabelBorder") SaveColorSetting rs, "Footer_LabelFont", Theme("Footer")("LabelFont") SaveColorSetting rs, "Button_Back", Theme("Button")("Back") SaveColorSetting rs, "Button_Border", Theme("Button")("Border") SaveColorSetting rs, "Button_Font", Theme("Button")("Font") SaveColorSetting rs, "Button_Hover", Theme("Button")("Hover") SaveColorSetting rs, "Button_Pressed", Theme("Button")("Pressed") SaveColorSetting rs, "Button_HoverFore", Theme("Button")("HoverFore") SaveColorSetting rs, "Button_PressedFore", Theme("Button")("PressedFore") SaveColorSetting rs, "Combo_Back", Theme("Combo")("Back") SaveColorSetting rs, "Combo_Border", Theme("Combo")("Border") SaveColorSetting rs, "Combo_Font", Theme("Combo")("Font") SaveColorSetting rs, "List_Back", Theme("List")("Back") SaveColorSetting rs, "List_Border", Theme("List")("Border") SaveColorSetting rs, "List_Font", Theme("List")("Font") rs.Close End Sub Private Sub LoadThemeFromCurrentForm() Dim ctl As Control Dim sec As String Theme("Header")("SectionBack") = Me.section(stHeader).BackColor Theme("Detail")("SectionBack") = Me.section(stDetail).BackColor Theme("Footer")("SectionBack") = Me.section(stFooter).BackColor For Each ctl In Me.Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select Theme(sec)("TextBack") = ctl.BackColor Theme(sec)("TextBorder") = ctl.BorderColor Theme(sec)("TextFont") = ctl.ForeColor Case ctComboBox Theme("Combo")("Back") = ctl.BackColor Theme("Combo")("Border") = ctl.BorderColor Theme("Combo")("Font") = ctl.ForeColor Case ctListBox Theme("List")("Back") = ctl.BackColor Theme("List")("Border") = ctl.BorderColor Theme("List")("Font") = ctl.ForeColor Case ctLabel Select Case ctl.section Case stHeader: sec = "Header" Case stDetail: sec = "Detail" Case stFooter: sec = "Footer" Case Else: GoTo NextControl End Select Theme(sec)("LabelBack") = ctl.BackColor Theme(sec)("LabelBorder") = ctl.BorderColor Theme(sec)("LabelFont") = ctl.ForeColor Case ctCommandButton Theme("Button")("Back") = ctl.BackColor Theme("Button")("Border") = ctl.BorderColor Theme("Button")("Font") = ctl.ForeColor On Error Resume Next Theme("Button")("Hover") = ctl.HoverColor Theme("Button")("Pressed") = ctl.PressedColor Theme("Button")("HoverFore") = ctl.HoverForeColor Theme("Button")("PressedFore") = ctl.PressedForeColor On Error GoTo 0 End Select NextControl: Next ctl End Sub Private Sub LoadThemeFromTable() Dim rs As DAO.Recordset On Error GoTo ErrHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM " & TABLE_NAME_THEME_SETTINGS) If rs.EOF Then LoadThemeFromCurrentForm Else Do Until rs.EOF Select Case rs(FIELD_NAME) Case "Header_SectionBack": Theme("Header")("SectionBack") = rs(FIELD_VALUE) Case "Header_TextBack": Theme("Header")("TextBack") = rs(FIELD_VALUE) Case "Header_TextBorder": Theme("Header")("TextBorder") = rs(FIELD_VALUE) Case "Header_TextFont": Theme("Header")("TextFont") = rs(FIELD_VALUE) Case "Header_LabelBack": Theme("Header")("LabelBack") = rs(FIELD_VALUE) Case "Header_LabelBorder": Theme("Header")("LabelBorder") = rs(FIELD_VALUE) Case "Header_LabelFont": Theme("Header")("LabelFont") = rs(FIELD_VALUE) Case "Detail_SectionBack": Theme("Detail")("SectionBack") = rs(FIELD_VALUE) Case "Detail_TextBack": Theme("Detail")("TextBack") = rs(FIELD_VALUE) Case "Detail_TextBorder": Theme("Detail")("TextBorder") = rs(FIELD_VALUE) Case "Detail_TextFont": Theme("Detail")("TextFont") = rs(FIELD_VALUE) Case "Detail_LabelBack": Theme("Detail")("LabelBack") = rs(FIELD_VALUE) Case "Detail_LabelBorder": Theme("Detail")("LabelBorder") = rs(FIELD_VALUE) Case "Detail_LabelFont": Theme("Detail")("LabelFont") = rs(FIELD_VALUE) Case "Footer_SectionBack": Theme("Footer")("SectionBack") = rs(FIELD_VALUE) Case "Footer_TextBack": Theme("Footer")("TextBack") = rs(FIELD_VALUE) Case "Footer_TextBorder": Theme("Footer")("TextBorder") = rs(FIELD_VALUE) Case "Footer_TextFont": Theme("Footer")("TextFont") = rs(FIELD_VALUE) Case "Footer_LabelBack": Theme("Footer")("LabelBack") = rs(FIELD_VALUE) Case "Footer_LabelBorder": Theme("Footer")("LabelBorder") = rs(FIELD_VALUE) Case "Footer_LabelFont": Theme("Footer")("LabelFont") = rs(FIELD_VALUE) Case "Button_Back": Theme("Button")("Back") = rs(FIELD_VALUE) Case "Button_Border": Theme("Button")("Border") = rs(FIELD_VALUE) Case "Button_Font": Theme("Button")("Font") = rs(FIELD_VALUE) Case "Button_Hover": Theme("Button")("Hover") = rs(FIELD_VALUE) Case "Button_Pressed": Theme("Button")("Pressed") = rs(FIELD_VALUE) Case "Button_HoverFore": Theme("Button")("HoverFore") = rs(FIELD_VALUE) Case "Button_PressedFore": Theme("Button")("PressedFore") = rs(FIELD_VALUE) Case "Combo_Back": Theme("Combo")("Back") = rs(FIELD_VALUE) Case "Combo_Border": Theme("Combo")("Border") = rs(FIELD_VALUE) Case "Combo_Font": Theme("Combo")("Font") = rs(FIELD_VALUE) Case "List_Back": Theme("List")("Back") = rs(FIELD_VALUE) Case "List_Border": Theme("List")("Border") = rs(FIELD_VALUE) Case "List_Font": Theme("List")("Font") = rs(FIELD_VALUE) End Select rs.MoveNext Loop End If rs.Close Set rs = Nothing ApplyThemePreview Exit Sub ErrHandler: If DebugMode Then Debug.Print "LoadThemeFromTable >> " & Err.Number & ": " & Err.Description End Sub Private Sub ApplyThemeToAllForms() Dim frm As Object Dim ctl As Control Dim i As Integer Dim arrSections As Variant Dim sec As section Dim secName As String arrSections = Array(stHeader, stDetail, stFooter) For Each frm In CurrentProject.AllForms On Error Resume Next DoCmd.OpenForm frm.Name, acDesign, , , , acHidden If Err.Number <> 0 Then If DebugMode Then Debug.Print "تعذر فتح النموذج: " & frm.Name Err.Clear GoTo NextForm End If On Error GoTo 0 For i = LBound(arrSections) To UBound(arrSections) Set sec = Forms(frm.Name).section(arrSections(i)) Select Case arrSections(i) Case stHeader: If Theme("Header")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Header")("SectionBack") Case stDetail: If Theme("Detail")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Detail")("SectionBack") Case stFooter: If Theme("Footer")("SectionBack") <> COLOR_UNSET Then sec.BackColor = Theme("Footer")("SectionBack") End Select Next i For Each ctl In Forms(frm.Name).Controls Select Case ctl.ControlType Case ctTextBox Select Case ctl.section Case stHeader: secName = "Header" Case stDetail: secName = "Detail" Case stFooter: secName = "Footer" Case Else: GoTo NextControl End Select If Theme(secName)("TextBack") <> COLOR_UNSET Then ctl.BackColor = Theme(secName)("TextBack") If Theme(secName)("TextBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(secName)("TextBorder") If Theme(secName)("TextFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(secName)("TextFont") Case ctComboBox If Theme("Combo")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Combo")("Back") If Theme("Combo")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Combo")("Border") If Theme("Combo")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Combo")("Font") Case ctListBox If Theme("List")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("List")("Back") If Theme("List")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("List")("Border") If Theme("List")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("List")("Font") Case ctLabel Select Case ctl.section Case stHeader: secName = "Header" Case stDetail: secName = "Detail" Case stFooter: secName = "Footer" Case Else: GoTo NextControl End Select If Theme(secName)("LabelBack") <> COLOR_UNSET Then ctl.BackColor = Theme(secName)("LabelBack") If Theme(secName)("LabelBorder") <> COLOR_UNSET Then ctl.BorderColor = Theme(secName)("LabelBorder") If Theme(secName)("LabelFont") <> COLOR_UNSET Then ctl.ForeColor = Theme(secName)("LabelFont") Case ctCommandButton If Theme("Button")("Back") <> COLOR_UNSET Then ctl.BackColor = Theme("Button")("Back") If Theme("Button")("Border") <> COLOR_UNSET Then ctl.BorderColor = Theme("Button")("Border") If Theme("Button")("Font") <> COLOR_UNSET Then ctl.ForeColor = Theme("Button")("Font") On Error Resume Next If Theme("Button")("Hover") <> COLOR_UNSET Then ctl.HoverColor = Theme("Button")("Hover") If Theme("Button")("Pressed") <> COLOR_UNSET Then ctl.PressedColor = Theme("Button")("Pressed") If Theme("Button")("HoverFore") <> COLOR_UNSET Then ctl.HoverForeColor = Theme("Button")("HoverFore") If Theme("Button")("PressedFore") <> COLOR_UNSET Then ctl.PressedForeColor = Theme("Button")("PressedFore") On Error GoTo 0 End Select NextControl: Next ctl DoCmd.Close acForm, frm.Name, acSaveYes NextForm: On Error GoTo 0 Err.Clear Next frm End Sub الكود الان يتيح تخصيص مظهر النماذج بشكل مركزي يوفر واجهة لتحديد ألوان الخلفية للأقسام (رأس، تفاصيل، تذييل) يوفر تحديد ألوان الخلفية و الحدود والنصوص للعناصر (مربعات نص - عناوين التسمية ) لكل قسم على حده يوفر تحديد ألوان الخلفية والنصوص للعناصر (مربعات نص - مربعات التحرير والسرد - قوائم القيم - أزرار ) يدعم معاينة فورية وتطبيق الثيم على جميع النماذج بنقرة واحدة مع خيار استعادة الإعدادات الافتراضية يتم حفظ الإعدادات في جدول قاعدة بيانات مما يضمن الاتساق عبر النماذج ينشئ الجدول فى حالة عدم وجوده يحدث البيانات للاعدادت داخل الجدول فى حالة وجود الجدول وأخيرا التعديل على مرفق حضرتك changColor(2).accdb

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

جزانا الله وإياكم خير الجزاء ان شاء الله انتم الأجمل احمد الله انها نالت رضاكم واسأل الله تعالى أن ينفعكم وينفعنا بما علمنا الحمد لله تعالى الذى تتم بنعمته الصالحات