عرض الوقت دون استعمال حدث عند الوقت ، ومن غير ما يأثر على محرر الأكواد أيضاً أثناء العمل

[Foksh]

[تعليق جعفر] بالاشارة الى الموضوع التالي

 

بعد فصل الموضوع عن رده في موضوعه المشار إليه أعلاه ..

بصوا على الخفة في الأداء😎 :-

Option Compare Database
Option Explicit

Const TargetControlName As String = "CyberClock"    ''    ' اسم عنصر عرض الوقت النصي ليبل/مربع نص/زر

#If VBA7 Then
    Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As LongPtr, ByVal pfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As LongPtr) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hWnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Public NativeTimerID As LongPtr
    Private WinEventHookID As LongPtr
    Private AccessHwnd As LongPtr
#Else
    Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hWnd As Long, ByVal gaFlags As Long) As Long
    Public NativeTimerID As Long
    Private WinEventHookID As Long
    Private AccessHwnd As Long
#End If

Private Const EVENT_SYSTEM_FOREGROUND As Long = &H3
Private Const WINEVENT_OUTOFCONTEXT As Long = &H0
Private Const GA_ROOT As Long = 2

Private gWasStoppedByVBE As Boolean
Private gTimerInterval As Long

#If VBA7 Then
Public Sub NativeTimerCallback(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
#Else
Public Sub NativeTimerCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
#End If
    On Error Resume Next
    Dim currentTime As Variant
    Dim timeText As String
    currentTime = Now()
    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dddd, dd/mm/yyyy")
    
''    ' 1. الوقت فقط (سطر واحد)
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM")
'
''    ' 2. التاريخ فقط (سطر واحد)
''    timeText = Format$(currentTime, "dd/mm/yyyy")
'
''    ' 3. الوقت والتاريخ في سطر واحد
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & " - " & Format$(currentTime, "dd/mm/yyyy")
'
''    ' 4. الوقت فوق التاريخ (سطرين)
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dd/mm/yyyy")
'
''    ' 5. التاريخ فوق الوقت (سطرين)
''    timeText = Format$(currentTime, "dd/mm/yyyy") & vbCrLf & Format$(currentTime, "hh:nn:ss AM/PM")
'
''    ' 6. الوقت مع اسم اليوم والتاريخ (سطر واحد)
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & " - " & Format$(currentTime, "dddd, dd/mm/yyyy")
'
''    ' 7. التاريخ مع اسم اليوم فقط (سطر واحد)
''    timeText = Format$(currentTime, "dddd, dd/mm/yyyy")
'
''    ' 8. التاريخ مع اسم اليوم فوق الوقت (سطرين)
''    timeText = Format$(currentTime, "dddd, dd/mm/yyyy") & vbCrLf & Format$(currentTime, "hh:nn:ss AM/PM")
'
''    ' 9. الوقت فقط مع ثواني بصيغة 24 ساعة
''    timeText = Format$(currentTime, "HH:nn:ss")
'
''    ' 10. الوقت مع التاريخ مختصر (رقم الشهر بدل اسمه)
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dd/mm/yy")
'
''    ' 11. تنسيق أمريكي (شهر/يوم/سنة)
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "mm/dd/yyyy")
'
''    ' 12. مع اسم اليوم والمختصر
''    timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "ddd, dd/mm/yyyy")  ' Mon, 15/04/2026
'
''    ' 13. نص مخصص بالكامل
''    timeText = "الوقت: " & Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & "التاريخ: " & Format$(currentTime, "dddd, dd/mm/yyyy")
    
    Dim frm As Object, ctl As Object, target As Object
    
    For Each frm In Forms
        Err.Clear
        Set target = frm.Controls(TargetControlName)
        If Err.Number = 0 Then
            target.Caption = timeText
            target.Value = timeText
        End If
        
        For Each ctl In frm.Controls
            Err.Clear
            Set target = ctl.Form.Controls(TargetControlName)
            If Err.Number = 0 Then
                target.Caption = timeText
                target.Value = timeText
            End If
        Next ctl
        
        Err.Clear
        Dim LineS As Object, LineM As Object, LineH As Object
        Dim CX As Long, CY As Long
        Dim Radius As Long
        
        Set LineS = frm.Controls("LineSec")
        Set LineM = frm.Controls("LineMin")
        Set LineH = frm.Controls("LineHour")
        
        If Err.Number = 0 Then
            CX = frm.Controls("Line02").Left + (frm.Controls("Line02").Width / 2)
            CY = frm.Controls("Line01").Top + (frm.Controls("Line01").Height / 2)
            
            Radius = frm.Controls("Line02").Width / 2
            
            Dim secAngle As Double, minAngle As Double, hrAngle As Double
            secAngle = Second(currentTime) * 6
            minAngle = Minute(currentTime) * 6 + (Second(currentTime) * 0.1)
            hrAngle = (Hour(currentTime) Mod 12) * 30 + (Minute(currentTime) * 0.5)
            
            DrawClockHand LineS, CX, CY, CLng(Radius * 0.9), secAngle
            DrawClockHand LineM, CX, CY, CLng(Radius * 0.75), minAngle
            DrawClockHand LineH, CX, CY, CLng(Radius * 0.5), hrAngle
        End If
        
    Next frm
End Sub

Public Sub DrawClockHand(ByRef ctlLine As Object, ByVal CX As Long, ByVal CY As Long, ByVal L As Long, ByVal AngleDeg As Double)
    Const Pi As Double = 3.14159265358979
    Dim Rad As Double
    Dim EX As Long, EY As Long
    
    Rad = AngleDeg * Pi / 180
    
    EX = CX + (L * Sin(Rad))
    EY = CY - (L * Cos(Rad))
    
    ctlLine.Width = Abs(EX - CX)
    ctlLine.Height = Abs(EY - CY)
    
    If ctlLine.Width = 0 Then ctlLine.Width = 1
    If ctlLine.Height = 0 Then ctlLine.Height = 1
    
    If EX < CX Then ctlLine.Left = EX Else ctlLine.Left = CX
    If EY < CY Then ctlLine.Top = EY Else ctlLine.Top = CY

    If Sgn(EX - CX) = Sgn(EY - CY) Or Sgn(EX - CX) = 0 Or Sgn(EY - CY) = 0 Then
        ctlLine.LineSlant = False
    Else
        ctlLine.LineSlant = True
    End If
End Sub

Public Sub StartNativeTimer(Optional ByVal IntervalMs As Long = 500)
    gTimerInterval = IntervalMs
    If NativeTimerID = 0 Then
        NativeTimerID = SetTimer(0, 0, IntervalMs, AddressOf NativeTimerCallback)
    End If
    If WinEventHookID = 0 Then
        WinEventHookID = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0, AddressOf ForegroundChangedProc, 0, 0, WINEVENT_OUTOFCONTEXT)
    End If
End Sub

Public Sub StopNativeTimer()
    If NativeTimerID <> 0 Then
        KillTimer 0, NativeTimerID
        NativeTimerID = 0
    End If
    If WinEventHookID <> 0 Then
        UnhookWinEvent WinEventHookID
        WinEventHookID = 0
    End If
End Sub

Private Function IsVBEOpen() As Boolean
    On Error Resume Next
    IsVBEOpen = Application.VBE.MainWindow.Visible
    If Err.Number <> 0 Then IsVBEOpen = False
    On Error GoTo 0
End Function

#If VBA7 Then
Public Sub ForegroundChangedProc(ByVal hWinEventHook As LongPtr, ByVal eventId As Long, ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
#Else
Public Sub ForegroundChangedProc(ByVal hWinEventHook As Long, ByVal eventId As Long, ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
#End If
    On Error Resume Next
    If AccessHwnd = 0 Then AccessHwnd = Application.hWndAccessApp
    
    If IsVBEOpen() Then
        If NativeTimerID <> 0 Then
            KillTimer 0, NativeTimerID
            NativeTimerID = 0
            gWasStoppedByVBE = True
        End If
    Else
        If gWasStoppedByVBE Then
            If GetAncestor(hWnd, GA_ROOT) = AccessHwnd Then
                If NativeTimerID = 0 Then
                    NativeTimerID = SetTimer(0, 0, gTimerInterval, AddressOf NativeTimerCallback)
                End If
                gWasStoppedByVBE = False
            End If
        End If
    End If
End Sub

وطبعاً الإستدعاء هيكون فقط زي كدة :-

Private Sub Form_Load()
    StartNativeTimer
End Sub

Private Sub Form_Unload(Cancel As Integer)
    StopNativeTimer
End Sub

 

والملف البسيط ده هدية كبيرة مني لموضوعك المشار إليه  

نموذج يحتوي فرعي ,, ونموذج رئيسي ، وساعة بالعقارب ورقمية ...

 

Time With No TimerInterval.accdb

 

ودي صورة كمان تخليك تستغرب إن الوقت والساعة شغالين في وضع التصميم لو عاوز .. يعني الحدث عند الوقت ملهوش أي اعتبار عندي هنا .

 

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

[ابو جودي]

منذ ساعه, Foksh said:

ودي صورة كمان تخليك تستغرب إن الوقت والساعة شغالين في وضع التصميم لو عاوز .. يعني الحدث عند الوقت ملهوش أي اعتبار عندي هنا .

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

النقطة هنا مش إن "الكود يشتغل وخلاص" لكن يشتغل بشكل قابل للتوسعة ويكون مستقر ومتوافق مع بيئة أكسس

الحل المعتمد على SetTimer بسيط في الظاهر لكنه :
يعمل خارج دورة عمل النماذج الطبيعية ويمر على جميع النماذج مع كل تحديث زمني ولا يملك إدارة حالة مستقلة لكل نموذج
 

فوق ده كله الاعتماد على On Error Resume Next معناه تجاهل الأخطاء بدل حلها وكأن المشكلة ستختفي بمجرد إخفائها وهذا ليس حلا بل تأجيل للأزمة فقط

ومع نمو التطبيق، النتيجة المتوقعة واضحة:
تراجع في الاستقرار و انخفاض في الأداء وزيادة في صعوبة الصيانة 

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

 

منذ ساعه, Foksh said:

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

أما نقطة "ما تحللش كتير في الكود ، هو بسيط و واضح ومقروء" :
دي مش حجة على قوة و لا على كفائة الكود فهي لا تعكس بساطته بل تتجاهل تقييم تصميمه وتأثيره على المدى الطويل

الخلاصة:
من يريد كودا قابلا للتوسع والاستقرار يختار TimerInterval
أما من يريد حلا سريعا يبدو ذكيا في اللحظة الأولى فليستمر مع SetTimer

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

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

[Foksh]

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

فوق ده كله الاعتماد على On Error Resume Next معناه تجاهل الأخطاء بدل حلها وكأن المشكلة ستختفي بمجرد إخفائها وهذا ليس حلا بل تأجيل للأزمة فقط

فعلاً ده كان رد الذكاء الصناعي لما سألته عن الكود 

خلاف ذلك ، ليس محل نقاش . فيما رأيته :-

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

فكرة إن الساعة تشتغل حتى في وضع التصميم

شكراً لتفاعلك  😎

[jjafferr]

السلام عليكم

انا لا استعمل الساعة في اي من برامجي ،

اضطر للتعامل مع Timer Interval في بعض النماذج لفحص مجلدات معينة (هناك مجلد مشاركة بين المستخدمين ، والبرنامج يراقب هذا المجلد ، فلما يجد فيه ملف معين ، يقوم بعمل معين) ، هذا النوع من المجلدات يسمى Hot Folder.

اثناء عمل هذا البرنامج (فكر به كأنه ساعة ، تغير المعاينة كل ثانية) ، لما ادخل الكود ، لا استطيع الكتابة بسلاسة ، بسبب Time Interval نموذج آخر.

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

[Foksh]

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

اضطر للتعامل مع Timer Interval في بعض النماذج لفحص مجلدات معينة (هناك مجلد مشاركة بين المستخدمين ، والبرنامج يراقب هذا المجلد ، فلما يجد فيه ملف معين ، يقوم بعمل معين) ، هذا النوع من المجلدات يسمى Hot Folder.

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

أهلاً بك معلمي الفاضل @jjafferr ، وأشكرك جداً على هذه الملاحظة الدقيقة والمهنية . نقطتك في محلها تماااااماً ؛ فالتحديث الأول أوقف التايمر الخاص به فقط ولكنه لم يتدخل في تايمرات النماذج التقليدية ( Timer Interval ) كاستخدامك لها في الـ ( Hot Folders ) ، مما استمر في مقاطعتك كمطور عند كتابتك للأكواد داخل المحرر .

ولذلك ، ولحل هذه المعضلة بشكل جذري وجعل الفكرة ناجحة 100% ، قمت بتوسيع مهام حدث الويندوز ForegroundChangedProc .

الفكرة الآن أنه وبمجرد مرور تركيز الويندوز إلى نافذة محرر الأكواد VBA ، سيقوم الكود بمسح جميع النماذج المفتوحة بلحظة واحدةً ، وبالتالي يحفظ قيم التايمر لها - عند وجود الحدث فقط - في ذاكرة مؤقتة ، ويجعل التايمر = 0 . وعند إغلاقك المحرر ، سيعيد الاستئناف بدقة لكل نموذج بناءً على ما تم حفظه في الذاكرة .

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

• سنقوم بالإعلان عن متغير ( الذاكرة المؤقتة ) الذي ستعيش وتموت مع فتح وإغلاق محرر الأكواد VBA ، كالآتي :-

Private colPausedForms As Collection

 

• الإضافة الثانية ( عملية الإيقاف والفكشنة عند فتح VBA ) . وتكون في الجزء الأول من دالة ForegroundChangedProc داخل شرط If IsVBEOpen() Then ، وهي المسؤولة عن حصر النماذج المفتوحة لدالة الصيد لتقوم بإيقافها وتتبع النماذج الفرعية داخلها :-

            Set colPausedForms = New Collection
            Dim frmMain As Object
            For Each frmMain In Forms
                PauseAllTimers frmMain
            Next frmMain

 

• الإضافة الثالثة ، وتكون في الجزء الثاني Else عند إغلاق الـمحرر ، وهي المسؤولة عن إعادة الروح للتايمرات وقيمها الأصلية كما كانت عليه :-

                    If Not colPausedForms Is Nothing Then
                        Dim frmMain2 As Object
                        For Each frmMain2 In Forms
                            ResumeAllTimers frmMain2
                        Next frmMain2
                        Set colPausedForms = Nothing
                    End If

 

• أما الإضافة الرابعة والأخيرة 😅 ( دالتين صغيرتين بمثابة محركات البحث المتداخل ) ، لكتابة وحفظ البصمات 😁 :-

Private Sub PauseAllTimers(frm As Object)
    If frm.TimerInterval > 0 Then
        On Error Resume Next
        colPausedForms.Add frm.TimerInterval, CStr(frm.Hwnd)
        frm.TimerInterval = 0
        On Error GoTo 0
    End If
    
    Dim ctl As Object
    On Error Resume Next
    For Each ctl In frm.Controls
        If ctl.ControlType = 112 Then 
            If Not ctl.Form Is Nothing Then PauseAllTimers ctl.Form
        End If
    Next ctl
    On Error GoTo 0
End Sub

Private Sub ResumeAllTimers(frm As Object)
    On Error Resume Next
    Dim savedInterval As Long: savedInterval = 0
    savedInterval = colPausedForms(CStr(frm.Hwnd))
    If savedInterval > 0 Then frm.TimerInterval = savedInterval
    
    Dim ctl As Object
    For Each ctl In frm.Controls
        If ctl.ControlType = 112 Then
            If Not ctl.Form Is Nothing Then ResumeAllTimers ctl.Form
        End If
    Next ctl
    On Error GoTo 0
End Sub

 

الآن الكود بحلته الجديدة وملفه الجديد تالياً ( فضلاً لا أمراً ، افتح النموذج Frm_WithTimerInterval ) وضع به ما شئت من نماذج فرعية بداخل بعضها البعض ذات تايمرات مستمرة ! ثم جرب الدخول إلى المحرر

 

 

 

 

Time With No TimerInterval.accdb

تم تعديل منذ 10 ساعات بواسطه Foksh
تصحيح خطأ إملائي ..

[jjafferr]

المعذرة ، اعتقد صار فيه اشباه في الموضوع وفي طلبي ، وما كان مفروض اخليه في موضوعك !!

 

انا قلت

11 ساعات مضت, jjafferr said:

اثناء عمل هذا البرنامج .. ، لما ادخل الكود ، لا استطيع الكتابة بسلاسة ، بسبب Time Interval نموذج آخر

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

وخلال عمل ذلك النموذج ، اريد ان اعدل الكود في نموذج آخر ، بحيث اشتغل فيه كالمعتاد ولا يسبب لي مشكلة في كتابة الكود.

 

 

[Foksh]

منذ ساعه, jjafferr said:

وخلال عمل ذلك النموذج ، اريد ان اعدل الكود في نموذج آخر ، بحيث اشتغل فيه كالمعتاد ولا يسبب لي مشكلة في كتابة الكود.

اهاااا .. فهمتك الحين ..

يعني كتشبيه بسيط !!

كالميكانيكي الذي يريد إصلاح ماتور سيارة أثناء سيرها  ..

بلهجتنا الأردنية = كيف .. ليش .. وين .. متى ؟؟ هو حر يدبر راسه ، و يفك الماتور ويصلحه والسيارة شغالة  .

 

وبما أنك مصر على الوقوف عند عقدة آكسيس ، لم لا تنقل حدثك من عند الوقت الى دالتي المتواضعة ( NativeTimerCallback ) 😎 !!

وبما أن كود مراقبة المجلدات لا يعتمد على التعديل الرسومي للواجهة ، فإنه سيستمر بالعمل أخي جعفر ، بل ومراقبة المجلدات كل ثانية في الخلفية ، حتى وأنت داخل محرر الأكواد ، تستطيع تكتب أكوادك بكل هدوء وسلام 😏 ..