ابو جودي

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

36 دقائق مضت, ابو البشر said:

- للاسف لم يسعفني الوقت لاكمال التصميم بسبب انشغالي هذه الفترة

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

3 دقائق مضت, ابوخليل said:

نعم .. نعم .. هو كذا يا باشمهندس

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

ادامك الله فوق رؤسنا وحفظكم لنا ولأحبابكم

الحمد لله الذى تتم بنعمته الصالحات

السلام عليكم استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل 

23 ساعات مضت, ابوخليل said:

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

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

ولكن حضرتك تريد فتح كافة النماذج فى وضع التصميم وتطبيق كل التعديلات على كافة النماذج لخدمة المصمم

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

لقد قمت بكتابة الكود بالشكل التالى :

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

2 ساعات مضت, ابوخليل said:

المهم .. هي الفكرة .. تعتبر بدائية .. حيث عملت نموذج بسيط يشتمل على :

مربع نص / مربع تسمية / مربع تحرير / قائمة / زر

افتح النموذج على التصميم واعدل في الوان المقاطع والعناصر كما يحلو لي

ثم افتح النموذج على العرض لأطلع على النتيجة وافحص الزر

اذا كل شيء تمام انقر زر الحفظ ( يتم حفظ خصائص الالوان في الجدول )

 

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

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

التحكم الشامل والكامل والمرن فى كل جزئية وما يحتويه من عناصر

>>-------->  سوف اطلع على مرفق حضرتك


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

في 4‏/7‏/2025 at 20:50, ابو جودي said:

شرح سريع 
زر الامر : Prev Theme  الانتقال الى الثيم السابق
زر الامر : Next Theme  الانتقال الى الثيم التالى 
ملحوظة يتم تطبيق كل ثيم بمجرد الضغط على ازرار الانتقال التالى والسابق كمعاينة فقط فى النموذج الحالى للاعدادت الثيم

زر الامر : Set as Default Theme  لجعل الثيم الحالى هو الثيم الافتراضى الذى يتم تطبيقه على كافة النماذج 

الازرار 
Header Section
Detail Section
Footer Section

بداخلهم عناصر التحكم بالعناصر بشكل عام لكل مقطع على حده 

ممكن تغيير اللون لاى جزئيه تفضلها من خلال اختيار اللون من منتقى الالوان بالضغط على زر الامر : Pick Color الموجود بجانب كل عنصر والخاص به

زر الامر : Only Preview   من خلاله يتم تطبيق الالوان التى تم تعديلها واختيارها من منتقى الالوان لتتم المعاينة فقط فى النموذج الحالى 

فى حالة لم تعجبك الالوان بعد التعديلات فقط اغلق النموذج

فى حالة اعجبك كل شئ بعد عمل المعاينة للتعديلات هنا يأتى دور زر الامر الاخيــــــــر 

زر الأمر : Save Color To Theme هو المسئول هن الاحتفاظ بالقيم الجديدة بعد تحديثها داخل جدول اعدادات الثيم لتبقى مخزنة وفق تعديلاتك التى اعجبت بها وتريد الاحتفاظ بها لها الثيم
 الثيمات(2).accdb 888 kB · 14 downloads

في 3‏/7‏/2025 at 18:07, mohammed farhat said:

جزاكم الله خير فكره جميلة جدا و يحتاجها كل مطوري الاكسيس 

 

جزانا الله وإياكم خير الجزاء ان شاء الله

انتم الأجمل

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

الحمد لله تعالى الذى تتم بنعمته الصالحات

كنت عامل موضوع بهذا الخصوص ولكن لتصفير و حذف بيانات أكثر من جدول ان اردت التوسع

هذا رابط الموضوع

https://www.officena.net/ib/topic/106503-حذف-بيانات-جداول-منضمة-ومرتبطه-دفعة-واحدة-على-حسب-اختيارك/#comment-642632

3 ساعات مضت, Moosak said:

من مكتبتي العامرة وجدت هذا النموذج وقد مر علي سابقا في عدة برامج 🙂 

للأسف لا أعلم صاحبه الأصلي ولكنه تقريبا يحقق المطلوب 🙂 

ويتم تنفيذه وتطبيقه على جميع النماذج

 

عمل ثيمات لونية للنماذج يمكن تغييرها من قبل المستخدم بكل سهولة.zip 60.67 kB · 0 downloads

يا هلا والله ... والله اشتقنا

اتوحشتك كتير يا مولانا 

بارك الله لنا فى المكتبة العامرة وصاحب المكتبة

جزاكم الله خيرا 

والله موضوع الازرار فكرت فيه واجلته لو تم طلبه قلت ابقى اعمله

سبب ما انى ما عملتش كود الازرار

انه هيلغى تدرج الوان الازرار لو تم عمل تدرج لأى ازرار فى التصميم

ولكن ممكن اعمله وهتكون موجودة نسختين

وكل واحد يستخدم اللى يفضله

لكن انا منتظر الرد من استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل 

بحيث تتم التعديلات بناء على رغبة معلمى فى حال كانت له رغبات وتطلعات اخرى

مش عارف الافكار عجبتكم واللا ايه محدش رد خالص

على كل دى التجربة الثانية للتطوير
 

اولا افتح الجدول باسم : tblThemeSettings

تأكد انه فارغ

ثم بعد ذلك قم بفتح النموذج : frmTheme والذى بدوره يضيف البيانات الى الجدول السابق فى حال كان الجدول فارغا

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

ويمكن تجربة الثيم الذى يتم اختياره من النموذج : as a test Only

ليه انا سميت  النموذج : frmTheme بالنموذج السحرى

اولا هو غير مرتبط بالجدول وغير منضم اساسا   سامع اللى بيقول ما ده شئ عادى وبيحصل

طيب لكل ثيم عدد 3 سجلات ليه 3
1- الاول للتحكم فيما يخص المقطع Header
2- الثانى للتحكم فىما يخص المقطع Detail
3- الثالث للتحكم فيما يخص المقطع Footer

طيب لاحظو معى ان زر الامر التالى و زر امر السابق  لا يتم استعراض السجلات من خلالهم بل يتم استعراض الثيمات
طيب وبما ان لكل ثيم 3 سجلات 
سوف يتم الاستعراض للسجلات الثلاث كل سجل من التبويب الخاص به

هههههههه شغل مجانين صحيح محدش يزعق اتحملونى


شرح سريع 
زر الامر : Prev Theme  الانتقال الى الثيم السابق
زر الامر : Next Theme  الانتقال الى الثيم التالى 
ملحوظة يتم تطبيق كل ثيم بمجرد الضغط على ازرار الانتقال التالى والسابق كمعاينة فقط فى النموذج الحالى للاعدادت الثيم

زر الامر : Set as Default Theme  لجعل الثيم الحالى هو الثيم الافتراضى الذى يتم تطبيقه على كافة النماذج 

الازرار 
Header Section
Detail Section
Footer Section

بداخلهم عناصر التحكم بالعناصر بشكل عام لكل مقطع على حده 

ممكن تغيير اللون لاى جزئيه تفضلها من خلال اختيار اللون من منتقى الالوان بالضغط على زر الامر : Pick Color الموجود بجانب كل عنصر والخاص به

زر الامر : Only Preview   من خلاله يتم تطبيق الالوان التى تم تعديلها واختيارها من منتقى الالوان لتتم المعاينة فقط فى النموذج الحالى 

فى حالة لم تعجبك الالوان بعد التعديلات فقط اغلق النموذج

فى حالة اعجبك كل شئ بعد عمل المعاينة للتعديلات هنا يأتى دور زر الامر الاخيــــــــر 

زر الأمر : Save Color To Theme هو المسئول هن الاحتفاظ بالقيم الجديدة بعد تحديثها داخل جدول اعدادات الثيم لتبقى مخزنة وفق تعديلاتك التى اعجبت بها وتريد الاحتفاظ بها لها الثيم

 

الثيمات(2).accdb

طيب ده التصور المبدئى اللى خطر على بالى 

اممم

ممكن يتم التطوير لاحقا بناء على رغباتكم لو لاقت الافكار هنا اعجابكم 

الثيمات.accdb

2 دقائق مضت, ابوخليل said:

جميل .. هذا نصف الطريق

نريد نموذجا على طريقة الأخ موسى _ فقط _ يجلب الى اي مشروع

يتم التحكم بكل مقطع  وتفاصيله لوحده

11 دقائق مضت, Foksh said:

تحت أمرك 

اعمل لك فكرة الثيمات اللى مع الساعه الانلوج ؟
ليتم تطبيقها على كامل المشروع

والدى الحبيب
انظر الى فكرة تغيير الالوان هنا
 

الذكر الحكيم.zip

AnalogClock Without Timer Event.zip

وعليكم السلام ورحمة الله تعالى وبركاته

جزاكم الله خيـــــــرا
اسال الله تعالى ان يعفو ويغفر لوالدك و والدى ويرحمهم رحمة واسعة وكل المسلمين الاحياء منهم والاموات وان يسكنهم الفردوس الاعلى ان شاء الله

تسلم ايدك يا فنان

17 دقائق مضت, ابو جودي said:

وتتم عملية الاتصال مبدئيا بجهاز السيرفر من خلال حفظ معلومات الاتصال (حفظ بيانات الاعتماد ) من خلال اول نموذج

هذا الموضوع خصيصا قد يكون جديد بهذا الشكل على مجتمع مستخدمين قواعد بيانات أكسس
 

43 دقائق مضت, ابوخليل said:

اذا قاعدة البيانات على الشبكة فكان الله في عونهم

يتم عمل الحماية للمجلد كما اشرت
يتم فتح قاعدة البيانات الامامية من خلال قاعدة مشفرة accde 
ولا ننسى توفيرها مره للنواة 32 بت ومرة أخرى للنواة 64 بت
ويمكن للمبرمج الاحتفاظ بالقاعدة قبل التشفير واستخدامها مع كل تطبيقاته لو استخدم نفس تشفير القواعد الامامية بنفس كلمة المرور


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

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

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

وممكن احفاء كلمة مرور الاتصال لجهاز السيرفر عن المستخدمين اساسا
وتتم عملية الاتصال مبدئيا بجهاز السيرفر من خلال حفظ معلومات الاتصال (حفظ بيانات الاعتماد ) من خلال اول نموذج

وكل ما سبق موجود فى المنتدى

طيب و بمناسبة الرفع والشوط

منذ ساعه, ابوخليل said:

بترجع تقول اعمل حماية ما تقدر تدخل فلاشة 

 

والله مش هزعلك

اتفضل
1- Show And Hdie
لاخفاء واظهار الامر الخاص باخفاء واظهار الملفات والمجلدات

بعد الاخفاء سوف تكون بهذا الشكل

طبعا اى مجلدات او ملفات مخفيه لن يستطيع المستخدم الذى يريد العبث اعادة اظهارها والاطلاع عليها
لان أمر اظهار الملفات او المجلدات المخفيه اساسا اختفى


2- usb Open And Lock
تفعيل / عدم تفعيل قراءة اى شئ من منفذ USB

عند استخدام : USB LOOK
لو عندك الف منفذ Usb 
ادخل بهم اى فلاشة او هردات محمولة لن يتم قرائتها مطلقا
 

usb Open And Lock.zip Show And Hdie.zip

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل 

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

فى هذا الموضوع تحديدا لما احاول الاعتماد على اى برامج طرف ثالث 

منذ ساعه, شايب said:

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

 

جزاكم الله خيرا استاذى الجليل و معلمى القدير الاستاذ @شايب 

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

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

3 دقائق مضت, Foksh said:

تعملها ويطلع منك 

اتفضل الطريقة

4 دقائق مضت, Foksh said:

تفتكر هيكون آمن إذا استخدم لوحده بدون ( Salt ) ؟؟

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

نعم بدون حبة الملح : Salt  ولحالة آمن 

ولكن حبة الملح هذه تزيد من قوة التأمين فى فى التشفير جدا جدا جدا

7 دقائق مضت, ابوخليل said:

ولماذا ادخل من اجل احذف شيئا

الأسرع احذف البرنامج من جذوره واجهات وجداول وكل ما يحويه مجلد البرنامج .. وأريح راسي  .. وراس صاحب البرنامج 

ما هو لو حد رخم زى حلاتى ممكن يكون عامل حماية للمجلد من حذف ما فيه 

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

ثنائى الاتجاه يمكن التعرف عليه من خلال الهندسة العكسية

طيب كنت قد كتبت داله تعتمد على تشفير : MD5
ولكن انا كتبتها بدون الاعتماد على اى مكتبات تخص ال .net

وكذلك اعتمد على التشفير  : SHA256 لانه اكثر امانا من سابقه الا انه يعتمد على .net

ولكن بما اننى بقدر الامكان لا احب الاعتماد على اى مراجع ومكتبات خارجية بقدر الامكان 

فكرتى كانت الدمج بين التشفيرين بحيث اذا توفرت المكتة اللازمة يتم التشفير بناء على : SHA256 وان لم تتوفر فى نظام التشغيل يتم الاعتماد على التشفير : MD5

والاكواد كالاتى 

Private Function ToLong(ByVal dblValue As Double) As Long
    dblValue = dblValue - 4294967296# * Int(dblValue / 4294967296#)
    If dblValue < 0 Then dblValue = dblValue + 4294967296#
    If dblValue > 2147483647# Then
        ToLong = CLng(dblValue - 4294967296#)
    Else
        ToLong = CLng(dblValue)
    End If
End Function

Private Function RotateLeft32(ByVal lngValue As Long, ByVal intBits As Integer) As Long
    Dim dblValue As Double
    dblValue = CDbl(lngValue And &HFFFFFFFF)
    RotateLeft32 = ToLong(dblValue * (2 ^ intBits) + dblValue / (2 ^ (32 - intBits)))
End Function

Private Function GenerateSalt() As String
    Dim strChars As String, strResult As String
    Dim i As Long
    strChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    Randomize
    For i = 1 To 16
        strResult = strResult & Mid(strChars, Int(Rnd() * Len(strChars)) + 1, 1)
    Next
    GenerateSalt = strResult
End Function

Public Function MD5Hash(ByVal strText As String) As String
    Dim arrK(0 To 63) As Long, arrS(0 To 63) As Integer
    Dim a As Long, b As Long, c As Long, d As Long, f As Long, g As Long, temp As Long
    Dim h0 As Long, h1 As Long, h2 As Long, h3 As Long
    Dim msg() As Byte, msgLen As Long, paddedLength As Long
    Dim lenInBits As Currency
    Dim chunk(0 To 15) As Long
    Dim i As Long, offset As Long

    For i = 0 To 63
        arrK(i) = ToLong(Abs(Sin(i + 1)) * 4294967296#)
    Next i

    For i = 0 To 15: arrS(i) = Array(7, 12, 17, 22)(i Mod 4): Next i
    For i = 16 To 31: arrS(i) = Array(5, 9, 14, 20)(i Mod 4): Next i
    For i = 32 To 47: arrS(i) = Array(4, 11, 16, 23)(i Mod 4): Next i
    For i = 48 To 63: arrS(i) = Array(6, 10, 15, 21)(i Mod 4): Next i

    msg = StrConv(strText, vbFromUnicode)
    msgLen = UBound(msg) + 1
    paddedLength = ((msgLen + 8) \ 64 + 1) * 64
    ReDim Preserve msg(0 To paddedLength - 1)
    msg(msgLen) = &H80
    lenInBits = msgLen * 8
    For i = 0 To 7
        msg(paddedLength - 8 + i) = (lenInBits / (2 ^ (8 * i))) And &HFF
    Next i

    h0 = &H67452301
    h1 = &HEFCDAB89
    h2 = &H98BADCFE
    h3 = &H10325476

    For offset = 0 To paddedLength - 1 Step 64
        For i = 0 To 15
            chunk(i) = ToLong(CDbl(msg(offset + i * 4)) + _
                       CDbl(msg(offset + i * 4 + 1)) * &H100 + _
                       CDbl(msg(offset + i * 4 + 2)) * &H10000 + _
                       CDbl(msg(offset + i * 4 + 3)) * &H1000000)
        Next i

        a = h0: b = h1: c = h2: d = h3
        For i = 0 To 63
            If i < 16 Then
                f = (b And c) Or ((Not b) And d)
                g = i
            ElseIf i < 32 Then
                f = (d And b) Or ((Not d) And c)
                g = (5 * i + 1) Mod 16
            ElseIf i < 48 Then
                f = b Xor c Xor d
                g = (3 * i + 5) Mod 16
            Else
                f = c Xor (b Or (Not d))
                g = (7 * i) Mod 16
            End If

            temp = d
            d = c
            c = b
            b = ToLong(CDbl(b) + RotateLeft32(ToLong(CDbl(a) + f + arrK(i) + chunk(g)), arrS(i)))
            a = temp
        Next i

        h0 = ToLong(CDbl(h0) + a)
        h1 = ToLong(CDbl(h1) + b)
        h2 = ToLong(CDbl(h2) + c)
        h3 = ToLong(CDbl(h3) + d)
    Next offset

    MD5Hash = LCase( _
        Right("00000000" & Hex(h0), 8) & _
        Right("00000000" & Hex(h1), 8) & _
        Right("00000000" & Hex(h2), 8) & _
        Right("00000000" & Hex(h3), 8))
End Function

Public Function HashPasswordSHA256(ByVal Password As String) As String
    Dim xmlObj As Object
    Dim bytes() As Byte
    Dim hash() As Byte
    Dim i As Integer
    Dim result As String

    ' استخدام كائن MSXML2
    Set xmlObj = CreateObject("System.Security.Cryptography.SHA256Managed")

    ' تحويل النص إلى مصفوفة بايتات
    bytes = StrConv(Password, vbFromUnicode)

    ' حساب التجزئة
    hash = xmlObj.ComputeHash_2(bytes)

    ' تحويل النتيجة إلى سلسلة نصوص
    For i = LBound(hash) To UBound(hash)
        result = result & LCase(Right("0" & Hex(hash(i)), 2))
    Next i

    ' إعادة النتيجة النهائية
    HashPasswordSHA256 = result

    ' تنظيف الموارد
    Set xmlObj = Nothing
End Function

Public Function HashPassword(strPassword As String, Optional ByRef strSalt As String) As String
    If strSalt = "" Then strSalt = GenerateSalt()
    
    On Error GoTo UseMD5

    ' المحاولة الأولى باستخدام SHA-256
    HashPassword = HashPasswordSHA256(strPassword & strSalt)
    Exit Function

UseMD5:
    HashPassword = MD5Hash(strPassword & strSalt)
End Function

Public Sub UpdateExistingPasswords()
    On Error GoTo ErrHandler

    Dim rs As DAO.Recordset
    Dim strSalt As String

    ' تحديث جدول المستخدمين النشطين
    Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tblUsers", dbOpenDynaset)
    Do While Not rs.EOF
        If IsNull(rs!salt) Then
            strSalt = GenerateSalt()
            
            rs.Edit
                rs!salt = strSalt
                rs!UserPassword = HashPassword(rs!UserPassword, strSalt)
            rs.Update
            
            LogEvent "تم تحديث مستخدم: " & rs!UserID, Information, "UpdateExistingPasswords"
        End If
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing

    ' تحديث جدول المستخدمين المعلقين
    Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tbl01PendingUsers", dbOpenDynaset)
    Do While Not rs.EOF
        If IsNull(rs!salt) Then
            strSalt = GenerateSalt()
            rs.Edit
            rs!salt = strSalt
            rs!UserPassword = HashPassword(rs!UserPassword, strSalt)
            rs.Update
            LogEvent "تم تحديث مستخدم معلق: " & rs!UserID, Information, "UpdateExistingPasswords"
        End If
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing

    MsgBox "تم تحديث كلمات المرور القديمة بنجاح.", vbInformation
    Exit Sub

ErrHandler:
    HandleError "UpdateExistingPasswords", "حدث خطأ أثناء تحديث كلمات المرور"
    If Not rs Is Nothing Then rs.Close
End Sub

Public Sub UpdateExistingPasswordsByUserID(lngUserID As Long)
    On Error GoTo ErrHandler

    Dim rs As DAO.Recordset
    Dim strSalt As String

    ' تحديث جدول المستخدمين النشطين
    Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tblUsers WHERE UserID = " & lngUserID, dbOpenDynaset)
    If Not rs.EOF Then
        If IsNull(rs!salt) Then
            strSalt = GenerateSalt()
            rs.Edit
            rs!salt = strSalt
            rs!UserPassword = HashPassword(rs!UserPassword, strSalt)
            rs.Update
            LogEvent "تم تحديث مستخدم: " & rs!UserID, Information, "UpdateExistingPasswordsByUserID"
        End If
    End If
    rs.Close
    Set rs = Nothing

    ' تحديث جدول المستخدمين المعلقين
    Set rs = CurrentDb.OpenRecordset("SELECT UserID, UserPassword, Salt FROM tbl01PendingUsers WHERE UserID = " & lngUserID, dbOpenDynaset)
    If Not rs.EOF Then
        If IsNull(rs!salt) Then
            strSalt = GenerateSalt()
            rs.Edit
            rs!salt = strSalt
            rs!UserPassword = HashPassword(rs!UserPassword, strSalt)
            rs.Update
            LogEvent "تم تحديث مستخدم معلق: " & rs!UserID, Information, "UpdateExistingPasswordsByUserID"
        End If
    End If
    rs.Close
    Set rs = Nothing

    MsgBox "تم تحديث كلمة المرور بنجاح للمستخدم: " & lngUserID, vbInformation
    Exit Sub

ErrHandler:
    HandleError "UpdateExistingPasswordsByUserID", "حدث خطأ أثناء تحديث كلمة المرور للمستخدم: " & lngUserID
    If Not rs Is Nothing Then rs.Close
End Sub

طبعا الدوال الاخيرة : 
 

Public Sub UpdateExistingPasswords()

Public Sub UpdateExistingPasswordsByUserID(lngUserID As Long)

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


وجميعنا يعلم ان الامان هو : مسألة نسبية 
ولكن الجميع يحاول جاهد تأمين البيانات وتأمين الاكواد اما من العبث الغير مقصود او العبث المقصود او حفظا للحقوق

موضوع التأمين يختلف حسب توجهات كل شخص فى النهاية

وقوة وضعف التأمين تعتمد على افكار المبرمج فى النهاية بجانب لغة البرمجة

لمنع موضوع الحق

انا استخدم الداله

Public Function SafeSql(strValue As String) As String
    If IsNull(strValue) Or strValue = "" Then
        SafeSql = "NULL"
    Else
        SafeSql = "'" & Replace(strValue, "'", "''") & "'"
    End If
End Function

وامرر لها اسم المستخدم وكلمة المرور
 

strUserName = SafeSql(strUserName)

في 1‏/7‏/2025 at 10:23, ابوخليل said:

ويسمح لي اخي وحبيبي ابو جودي

استاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ @ابوخليل

حضرتك تتصرف كما يحلوا  لك حضرتك لك الأمر وعلي الطاعه