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

[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:

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

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