AbuuAhmed

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

    If Me.Dirty Then
        MsgBox "لقد تم التعديل على البيانات"
    End If

ويمكن كتابة الدالة كالتالي:
 

Function GetColor(Clr As Byte) As Long
    Select Case Clr
        Case 1:    GetColor = vbBlue
        Case 2:    GetColor = vbGreen
        Case 3:    GetColor = vbYellow
        Case 4:    GetColor = vbRed
        Case Else: GetColor = vbWhite
    End Select
End Function

أو هكذا:
 

Function GetColor(ByVal Clr As Variant) As Long
    Select Case Nz(Clr, 0)
        Case 1:    Clr = vbBlue
        Case 2:    Clr = vbGreen
        Case 3:    Clr = vbYellow
        Case 4:    Clr = vbRed
        Case Else: Clr = vbWhite
    End Select
    GetColor = Clr
End Function

ويمكن اختصار الإجراءين كالتالي:
 

Dim ctl As Control
    
For Each ctl In Me.Controls
    ctl.Visible = ctl.ControlType <> acTextBox
Next ctl
    
Set ctl = Nothing



    

Dim ctl As Control
    
For Each ctl In Me.Controls
    ctl.Enabled = ctl.ControlType <> acTextBox
Next ctl
    
Set ctl = Nothing

 قد لا يشعر بعضكم بالتعديل في إضافة صناديق التسميات في قسم رأس الصفحة،
عليه بفتح تقرير rptReport2 في طور التصميم وحذف كل صناديق التسميات في قسم رأس الصفحة ثم حفظه،
ثم تشغيل الإجراء AddReportPageHeaderLabels وإعادة فتح التقرير لمشاهدة نتيجة إضافة الصناديق.
للإستفادة الكاملة من حدث الإضافة ينصح بإضافة التسميات في الخاصية Tag لصناديق قسم التفاصيل .

أما من لا يريد استخدام هذا الإجراء ويرغب في إضافة التسميات بنفسه فينصح:
بإضافة أسماء صناديق قسم التفاصيل في خاصية ControlTipText لصناديق قسم رأس الصفحة.

أما بالنسبة للتقرير rptReport1 فقم بفتحه في طور التصميم وانظر إلى بعثرة صناديق التسميات في قسم رأس الصفحة،
ثم أعد فتحه في طور التشغيل لمشاهدة الصناديق وقد صفت بشكل منظم.

أعتقد أن هذا حل احترافي ويحتاج إلى عناية من المنتدى وكذلك العناية من أعضاء المنتدى ممن يستوعبون فكرته وجدواه.

موضوعك السابق لا يزال معلقا ويحتاج أن تنهيه وتعلق على الحل المقدم لك فيه.

لإضافة التسميات لقسم رأس الصفحة للتقرير في طور التصميم
لتنظيم التسميات لقسم رأس الصفحة للتقرير في طور التشغيل
 

'AbuuAhmed, Officena.net
'2023/06/15

Sub AddReportPageHeaderLabels(rptName As String)
    Dim acr As Byte, acrs As Byte
    Dim col As Byte
    Dim rpt As Report
    Dim ctl As Control, lbl As Control
    Dim lblName As String
    
    'لإضافة التسميات في قسم رأس الصفحة للتقارير متكررة الأعمدة في طور التصميم
    
    'On Error Resume Next
    
    DoCmd.OpenReport rptName, acViewDesign, , , acHidden
    Set rpt = Reports(rptName)
    
    acrs = rpt.Printer.ItemsAcross
    
    With rpt.Section(acPageHeader)
        Do While .Controls.Count > 0
            For Each ctl In .Controls
                Call DeleteReportControl(rptName, ctl.Name)
            Next ctl
        Loop
    
        For acr = 1 To acrs
            col = 0
            For Each ctl In rpt.Section(acDetail).Controls
                col = col + 1
                lblName = "col" & Format(col, "00") & Format(acr, "_00")
                Set lbl = CreateReportControl(rptName, acLabel, acPageHeader, , lblName)
                lbl.Name = lblName
                lbl.Caption = IIf(ctl.Tag = "", ctl.Name, ctl.Tag)
                lbl.ControlTipText = ctl.Name
                lbl.Left = ctl.Left
                lbl.Width = ctl.Width
                lbl.Top = lbl.Height * (acr - 1)
                lbl.TextAlign = 2
                lbl.BorderStyle = 1
                lbl.BackStyle = 1
                lbl.BackColor = RGB(216, 216, 216)
            Next ctl
        Next acr
    
        .Height = 0
    End With
    
    DoCmd.Close acReport, rptName, acSaveYes
    Set rpt = Nothing
    Set ctl = Nothing
    Set lbl = Nothing
    
    MsgBox "Done"
End Sub

Sub ReportOpen4PageHeader(rptName As String)
    Dim col As Byte, cols As Byte
    Dim acr As Byte, acrs As Byte
    Dim rpt As Report
    Dim ctl0 As Control, ctl1 As Control, ctl2 As Control
    
    'لتنظيم التسميات في قسم رأس الصفحة للتقارير متكررة الأعمدة في طور التشغيل
    
    On Error Resume Next
    
    Set rpt = Reports(rptName)
    
    rpt.Printer.ItemLayout = acPRVerticalColumnLayout
    rpt.Printer.DefaultSize = False
    
    cols = rpt.Section(acDetail).Controls.Count
    acrs = rpt.Printer.ItemsAcross
    
    For Each ctl0 In rpt.Section(acPageHeader).Controls
       With rpt.Controls(ctl0.ControlTipText)
            ctl0.Left = .Left
            ctl0.Width = .Width
       End With
    Next ctl0
    
    Set ctl0 = rpt("col" & Format(cols, "00") & "_01")
    
    rpt.Width = rpt.WindowWidth
    For acr = 2 To acrs
        For col = 1 To cols
            Set ctl1 = rpt("col" & Format(col, "00") & "_01")
            Set ctl2 = rpt("col" & Format(col, "00") & Format(acr, "_00"))
            
            With ctl2
                .Left = ctl0.Left + ctl0.Width + IIf(col = 1, rpt.Printer.ColumnSpacing, 0)
                .Top = ctl1.Top
                '.Width = ctl1.Width
                .Height = ctl1.Height
                .BackColor = ctl1.BackColor
                .ForeColor = ctl1.ForeColor
                .BackStyle = ctl1.BackStyle
                .Caption = ctl1.Caption
            End With
            
            Set ctl0 = ctl2
        Next col
    Next acr
    rpt.Width = 0
        
    With rpt.Section(acPageHeader)
        .Height = 0
        .Height = .Height + rpt("col01_01").Top
    End With
    
    Set rpt = Nothing
    Set ctl0 = Nothing
    Set ctl1 = Nothing
    Set ctl2 = Nothing
End Sub

حل للتقارير متعددة الأعمدة_01.accdb

جرب هذا المثال وبه استعانة بالكود
ويمكن عمل كود آخر أثناء التصميم لتكرار صناديق التسميات إذا أحببت.
 

Private Sub Report_Open(Cancel As Integer)
    Dim col As Byte, cols As Byte
    Dim acr As Byte, acrs As Byte
    Dim ctl0 As Control, ctl1 As Control, ctl2 As Control
    
    On Error Resume Next
    
    Me.Printer.ItemLayout = acPRVerticalColumnLayout
    Me.Printer.DefaultSize = False
    
    cols = Me.Section(0).Controls.Count
    acrs = Me.Printer.ItemsAcross
    Set ctl0 = Me("col" & Format(cols, "00") & "_01")
    
    Me.Width = Me.WindowWidth
    For acr = 2 To acrs
        For col = 1 To cols
            Set ctl1 = Me("col" & Format(col, "00") & "_01")
            Set ctl2 = Me("col" & Format(col, "00") & Format(acr, "_00"))
            
            With ctl2
                .Left = ctl0.Left + ctl0.Width + IIf(col = 1, Me.Printer.ColumnSpacing, 0)
                .Top = ctl1.Top
                .Width = ctl1.Width
                .Height = ctl1.Height
                .BackColor = ctl1.BackColor
                .ForeColor = ctl1.ForeColor
                .BackStyle = ctl1.BackStyle
                .Caption = ctl1.Caption
            End With
            
            Set ctl0 = ctl2
        Next col
    Next acr
    Me.Width = 0
        
    With Me.Section(3)
        .Height = 0
        .Height = .Height + Me.col01_01.Top
    End With
    
    Set ctl0 = Nothing
    Set ctl1 = Nothing
    Set ctl2 = Nothing
End Sub

تكرار عنوان التقرير_02.accdb

منذ ساعه, Moosak said:

أما الآن فدعونا نستمتع بإبداعاتكم

ويا أخ موسى الإشراف عندك هو حذف كل ما فيه انتقاد للمشرفين؟!!!
دع التعليقات إذا لا يوجد بها سباب أو إساءات.

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

إذا كان فهمي صحيح، فطلبك غير واضح بشكل كاف.
أنا بدلت الشرط:
 

[LastEdit]="..."

إلى:
 

[LastEdit]<="..."

وإذا رأيت أن الفكرة مقولبة فعدل الشرط إلى:
 

[LastEdit]>="..."

سجل بجميع التعديلات_02.accdb

يفترض بصاحب الموضوع متابعة موضوعه.

ارفع مثال أفضل لكم ولنا 🙂 وخصوصا أن الكود طويل، لاحظت بعض الأخطاء وربما هي ليس أخطاء فارفع مثالك لنعرف السبب وإذا عرف السبب .....
 

في 10‏/6‏/2023 at 09:49, وائل طه said:

وطبعا الارقام السرية مبقتش سريال بقي فيه أرقام واقعة في النص المطلوب

راجعت عمل الزميل دروب مبرمج، وأعجبني أنه أحتاج حقل واحد فقط وهو رقم المجموعة وهذا فيه توفير للمساحة.
العمل ممتاز ولكن الزميل لم يلتفت لملاحظة السائل وائل طه والموضحة أعلاه.
أما الكود فرأيت أن هذين السطرين لا يعملان، هل هما مطلوبان أم متروكان وتم نسيان أزالتهما؟:
 

    DoCmd.RunSQL "ALTER TABLE ]" & Tabel_Name & "] DROP COLUMN Str_Group"
    DoCmd.RunSQL "ALTER TABLE ]" & Tabel_Name & "] ADD Str_Group Number"

أرفق لكم القاعدة لفكرتي فقط حتى لا تشتت الفاحص للمثال.
مع ملاحة أني بدلت رقم السجل 4 إلى 400000 وحذف السجل الأخير لزوم التجارب.

تقسيم مجموعات_أبو أحمد_03.mdb

تعديل للكود السابق:
 

Private Sub Command1_Click()
    Dim strDB As String
    
    On Error Resume Next
    
    Set appAccess = CreateObject("Access.Application")
    
    Err.Clear
    strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".accdb"
    appAccess.OpenCurrentDatabase strDB
    'If Err.Number <> 0 Then
    If Err.Number = 7866 Then
        strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".mdb"
        appAccess.OpenCurrentDatabase strDB
    End If
    
    appAccess.DoCmd.OpenForm Me.form_open
    appAccess.Visible = True
    
    Set appAccess = Nothing
End Sub

طبعا دالة ترتيب السجل ثلاثة أرباعها أسطر زائدة، وذلك لأني بنيت الدالة على فكرة مختلفة ثم عدلت عنها في آخر الوقت ولم أقم بتنظيف الكود وتنقيحه.
الدالة بعد التنقيح:
 

Function GetSeq(ID As Long, Expr As String, Domain As String) As Long
    GetSeq = DCount(Expr, Domain, Expr & " <= " & ID)
End Function

سأقوم الليلة إن شاء الله بمراجعة مشاركة الزميل دروب مبرمج وأرجع لكم.

جرب هذا الكود:
 

Private Sub Command1_Click()
    Dim strDB As String
    
    strDB = CurrentProject.Path & "\FolderN\" & Me.n_Folder & "\" & Me.program & ".accdb"
    Set appAccess = CreateObject("Access.Application")
    appAccess.OpenCurrentDatabase strDB
    appAccess.DoCmd.OpenForm Me.form_open
    appAccess.Visible = True
    
    Set appAccess = Nothing
End Sub

تم عمل دالة للحصول على رقم ترتيب السجل ومن ثم الحصول على رقم المجموعة من خلال الإستعلام.
اسم الاستعلام Query3

يعاب على الدالة أنها بطيئة لأنها تقوم بفتح الجدول بعدد السجلات ولكنها تغنيكم عن تخزين/حفظ قيمة الترتيب والمجموعة.
إذا عجبتكم الفكرة غدا بإذن الله أفكر معكم في الخطوة الثانية.

والاستعلام Query4 لعرض أول وآخر رقم لكل مجموعة.

تقسيم الى مجموعات.accdb_02.mdb

أيضا جرب هذا الكود:
 

Private Sub Form_Current()
    Dim Msg As String
    
    If IsNull(Me.adadno) Then Exit Sub
    
   'If Me.adadno <> DLookup("[A]", "[Database]", "[crn] ='" & Me.adadno & "'") Then     'إذا كان الحقل نصي
    If Not IsNull(DLookup("[crn]", "[Database]", "[crn]=" & Me.adadno)) Then
        Msg = "القيمة " & Me.adadno & " موجودة هل تريد تكرارها؟"
        Beep
        If vbYes = MsgBox(Msg, vbQuestion + vbYesNo + vbDefaultButton2, "تننبيه") Then
            Exit Sub
        Else
            Undo
            'Exit Sub
        End If
    End If
End Sub

حولوا المرفق إلى 2003 خلوني أحاول معكم.

توجد مشكلة في الكود، عن طريق اختيار "التصحيح" debuging وسيقف المحرر على السطر مباشرة. 

47 دقائق مضت, AbuTalal20 said:

شكرا علي اهتمامك الرقي

ذكرتني بجاري "الظابط" دايما يردد هالكلمة وجاري هذا عنده مسكلة في الفهم، أنا لا أتكلم عنك لا سمح الله فأنت إنسان راقي، أن أتكلم عن جاري.

27 دقائق مضت, AbuTalal20 said:

احسن الظن بالله فإنه لا يخيب لك أمل ولا يضيع لك عمل

وأنت أحسن الكتابة والوصف، إثنان غيري لم يفهما عبارتك إلا لما أجبت على سؤال أبي خليل.
وأنا الحمد لله أحس الظن بالله ولكن لا أحب المجاملات ولا أقبل التصرفات السيئة وغير المحترمة وغير المسئولة من أي أحد كان.

منذ ساعه, AbuTalal20 said:

انا في قروب الواتسب حق الاكسس

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

شكرا لك أخي وموفق وخذها مني صريحة هذه آخر مشاركة لي في موضوعك 🙂.

هذا الموضوع ذكرني بموضوع شاركت فيه وصاحبه يعاني وسيستمر يعاني إن لم يسمع الكلام ويستفيد من نصائح الخبراء:

إذا كان الموضوع له علاقة بالوقت فالأمر يختلف ولكن إذا كان الأمر له علاقة بالتواريخ فلننتبه إلى التالي والفرق بينها:
في المدد هناك:
- نهاية المدة (آخر يوم في المدة)
End Date أو Last Date أو To Date
- تاريخ الإنتهاء أو تاريخ الإستئناف أو تاريخ مباشرة العمل بعد انقطاع (أول يوم بعد انتهاء مدة إجازة مثلا)
Expiry Date أو Resume Date 

فشهر يناير يبدأ من 01/01 وينتهي في 31/01 وليس 01/02 ومدته ستكون 31 يوم
والأسبوع يبدأ بالأحد وينتهي بالسبت وليس الأحد ومدته ستكون 7 أيام

فلنحسن المسمى لنحسن الحساب، لا أريد أن أتكلم عن خبراتي حتى لا تتعرفوا على شخصيتي الأصل 🙂 
لو سأحسب الغياب لموظف غاب يوم 5 يناير سأسجله في جدول يحتوي على حقلين مثلا سيكون غيابه من 05/01 إلى 05/01.

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

احمع عليها واحد
الحسبة الصح هي : 
تاريخ الاستلام - تاريخ التسليم + 1

طيب جميل والحمد لله أن الصورة اتضحت، فتعليقي لم يكن لانتقاصك ولكن هو حوار برمجي علمي.

 

'دالة من عمل أبي أحمد وأبي جودي
Function vbCEILING2(ByVal Num As Double, Optional ByVal Significance As Double = 1) As Double
    Dim Frac As Double
    
    Num = Num / Significance
    Frac = Num - Int(Num)
    
    vbCEILING2 = Int(Num) * Significance + IIf(Frac = 0, 0, Significance)
End Function

Test4myRoundFunctions_04.xlsm