نجوم المشاركات

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

جميل ، وهذا ما كنت اعمل عليه في هذه الفكرة ,, ودون شرحها هنا ، في المرفق نموذجين كأفكار قابلة للتحوير والتعديل حسب حاجتنا . مع العلم أنني قمت بإضافات قد لا تحتاجها ، ولكنها من باب الفضول والزيادة 😅 data1-1.zip

اعرض الملف إمنح تطبيقك المظهر الإحترافي بإستخدام مربع حوار المهام بديل لـ MsgBox {سلسلة الأدوات المساعدة المخصصة} أرفق لك إحدى الأدوات الرائعة التي يمكن أن تغنيك عن الكثير من النماذج وتجعل رسائل التنبيه تشبه رسائل ويندوز حاولت قد الإمكان تبسيط طريقة الإستخدام وتوضيحها في التعليقات أرجو أن تنال إعجابكم مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 07/05/25 الاقسام قسم الأكسيس  

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

وعليكم السلام ورحمة الله وبركاته 🤗 باعتقادي ، وبما أنك تجعل اسم الوثيقة هو رقم ، فهنا يجب أن تجعل اسم الوثيقة مربوطاً أيضاً برقم الموظف ( الأفضل ) ، أو اسم الموظف على سبيل المثال . هنا الوثيقة 1 للموظف1 ستختلف في الاسم عن الوثيقة 1 للموظف2 ، صحيح 😁 . لم أطلع على الملف ، أتابع من الهاتف حالياً.

نعم .. نعم .. هو كذا يا باشمهندس كذا الشغل والا بلاش .. سلمت أناملك .. وفكرك

حبيبي يا بروف انت ربنا يعلم من الأشخاص اللي اعتز بيهم انا بخير ماشي الحال اللي قولته دا فعلا من قلبي وقليل عليك انت تستاهل كل خير لانك فعلا انسان

اعتقد أن اللقب الجديد مش هيضيف للبروف شئ جديد لأنه من يزين الألقاب مجدا الف الف مبروك يا بروف دائما موفق

السلام عليكم استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممتاز الان اتضحت لى الفكرة تمام انا كانت فكرتى ان لا اقوم بتعديل الاعدادت داخل كافة النماذج ولكن فقط تطبيق الاعدادت الجديدة مع الاحتفاظ بالوضع الاصلى عند التصميم ولكن حضرتك تريد فتح كافة النماذج فى وضع التصميم وتطبيق كل التعديلات على كافة النماذج لخدمة المصمم وطامل انها لخدمة المصمم فقط وتريد كل الاكواد فى النموذج دون الاعتماد على وحدات نمطية ليسهل استخدام النموذج وما بجعبته مع اى قاعدة أخرى بمجرد نسخه اليها لقد قمت بكتابة الكود بالشكل التالى : 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

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

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

و عليكم السلام ورحمة الله وبركاته حسب فهمي للملف أن الكود يحول البيانات إلى أرقام و تواريخ حسب العمود. و لا أعرف لماذا تمت تسمية زر تشغيل الكود بلصق الاختيارت. قمت بتعديل أشاء بسيطة بالكود للتأكد من تنسيق الخلايا حسب المطلوب بس تأكد من التواريخ المكتوبة يوم و شهر تجرة(2).xlsb

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

افتح النموذج في عرض التصميم وفي تبويب بيانات في خصائص النموذج في خانة ادخال بيانات اختر لا شاهد الصورة

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

تفضل جرب الملف مصادقة 1.xlsx

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

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

في الحقيقة ، كانت من بين الأمور التي بحاجة لتعديلات ، و وجهة نظرك سليمة 100% أستاذنا الفاضل .. مبدعون في تخصصكم ، وما أنا إلا بمبتدئ في مجال الكسل أخي عبدالله ، ولكني وجدت أن المسار بين آكسيس وأكسل متشابه الى حد ما ، ما دفعني الى الخوض في تجربة التعرف على اكسل بشكل أعمق ( تعميق علاقة بيني وبينه 😂 ) .

تمام أخي الكريم ،، نستطيع تلافي المشكلة بإخفاء النموذج بشكل مؤقت أثناء المعاينة !! استخدم الكود التالي في زر المعاينة ، وجرب Private Sub btnPrint_Click() If lstResults.ListCount = 0 Then MsgBox "لا توجد نتائج لطباعتها", vbExclamation: Exit Sub End If Dim sh As Worksheet, nextRow As Long, i As Long, j As Long Const REPORT_SHEET As String = "تقرير الغياب" Me.Hide On Error Resume Next: Application.DisplayAlerts = False Worksheets(REPORT_SHEET).Delete Application.DisplayAlerts = True: On Error GoTo 0 Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sh.Name = REPORT_SHEET For j = 0 To lstResults.ColumnCount - 1 sh.Cells(1, j + 1).Value = "العمود " & j + 1 Next j sh.Range("A1:" & sh.Cells(1, lstResults.ColumnCount).Address).Font.Bold = True nextRow = 2 For i = 0 To lstResults.ListCount - 1 For j = 0 To lstResults.ColumnCount - 1 sh.Cells(nextRow, j + 1).Value = lstResults.List(i, j) Next j nextRow = nextRow + 1 Next i sh.Columns.AutoFit sh.PageSetup.Orientation = xlPortrait sh.PageSetup.Zoom = False sh.PageSetup.FitToPagesWide = 1 sh.PageSetup.FitToPagesTall = 1 sh.PrintPreview Me.Show End Sub

رغم أن معظم الأكواد تحتاج الى إعادة هيكلة وتصحيح ، ولكن جرب هذا المقترح ، بعد ما تمت تجربته على ملفك السابق :- Private Function GetDateColumn(ByVal searchDate As Date) As Long Dim cell As Range Dim searchRange As Range Set searchRange = wsData.Range(wsData.Cells(HEADER_ROW, DATE_COL_START), _ wsData.Cells(HEADER_ROW, wsData.Columns.Count)) For Each cell In searchRange If IsDate(cell.Value) Then If CDate(cell.Value) = searchDate Then GetDateColumn = cell.Column Exit Function End If End If Next cell GetDateColumn = 0 End Function جرب الملف التالي وشوف النتيجة Book5.zip

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

المسألة كالتالي : هذه صورة جدول الحضور من يوم 1/6 وحتى 11/6 الموظف مجاز ايام : 3 ، 4 ، 5 من الشهر بناء على ما تم رصده في جدول الاجازات وغائب يوم : 8 اريد في استعلام اظهار جميع الأيام .. وامام كل سجل حالته : حاضر او مجاز او غائب .. أو تكون ارقام 1 أو 2 أو 3 تعبر عن الحالة