Clock With Smart Timer 1.0.1

هذا الموضوع يعد مهماً وحيوياً لمصممي ومطوري النظم أكثر من المستخدم العادي

خاصة عند استخدام حدث Timer مع أي نموذج ويريد مطور النظام فتح محرر الأكواد (VBA) في نفس وقت عرض النماذج هنا تحدث المشكلة الكلاسيكية:

المطور لا يستطيع تعديل أي كود لأن التايمر النموذج يعطل التركيز داخل المحرر و يسبب أخطاء 

بفضل هذه الفكرة الثورية  هذا الأمر أصبح من الماضي السحيق

فكرة العمل باختصار

• 1 - عند فتح النموذج يبدأ TimerInterval تلقائياً
• 2 - إذا تم فتح محرر VBA بأى طريقة كانت يتم إيقاف التايمر فوراً
• 3 - عند إغلاق المحرر والعودة إلى النماذج يتم تشغيل التايمر من جديد تلقائياً وفوراً
• 4 - لا حاجة لتمرير اسم النموذج الرئيسي أو اسم عنصر الـ Subform يدوياً
• 5 - المطلوب فقط هو تمرير اسم عنصر التحكم الذي سيتم عرض الوقت فيه (Label أو TextBox) حسب الحاجة والرغبة

 مميزات الحل

• ذكـي : يكتشف النموذج الرئيسي والفرعي تلقائياً
• متعدد : يعمل مع أكثر من نموذج في نفس الوقت
• مـــرن : يدعم Label و TextBox كعناصر عرض للوقت
• آمـــن :  إذا تم حذف الوحدة النمطية يتحول تلقائياً إلى Fallback Mode باستخدام دالة الوقت الرئيسية :  Now()
• خفيف :  لا يعتمد على Timer إضافي للمراقبة
• جاهــز : يعمل مع النماذج الرئيسية و الفرعية أو الرئيسية المستقلة أو الرئيسية والفرعية معا

-----------------------------------------------------


الوحدة النمطية العامة

الاسم المقترح: basClockManager
الكود...

Option Compare Database
Option Explicit

#If VBA7 Then
    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
#Else
    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
#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 gHook                           As LongPtr
Private gAccessHwnd                     As LongPtr
Private gClocks                         As Object

Private Sub EnsureClockStore()
    If gClocks Is Nothing Then
        Set gClocks = CreateObject("Scripting.Dictionary")
    End If
End Sub

Private Function MakeClockKey(frm As Access.Form) As String
    On Error GoTo ErrorHandler

    Dim vParentForm As Access.Form
    Dim vControlName As String

    Set vParentForm = frm.Parent
    vControlName = GetSubformControlName(vParentForm, frm)

    If Len(vControlName) > 0 Then
        MakeClockKey = vParentForm.Name & "|" & vControlName & "|" & frm.Name
        Exit Function
    End If

ErrorHandler:
    MakeClockKey = frm.Name
End Function

Private Function CreateClockState(frm As Access.Form, _
                                  ByVal pControlName As String, _
                                  ByVal pIntervalMS As Long) As Object

    Dim vState As Object
    Set vState = CreateObject("Scripting.Dictionary")

    Dim vIsSubform As Boolean
    Dim vParentName As String
    Dim vSubCtlName As String

    On Error Resume Next
    vParentName = frm.Parent.Name
    vSubCtlName = GetSubformControlName(frm.Parent, frm)
    vIsSubform = (Len(vSubCtlName) > 0)
    On Error GoTo 0

    vState.Add "Key", MakeClockKey(frm)
    vState.Add "HostFormName", frm.Name
    vState.Add "ParentFormName", vParentName
    vState.Add "SubformControlName", vSubCtlName
    vState.Add "IsSubform", vIsSubform
    vState.Add "ControlName", pControlName
    vState.Add "WasStoppedByVBE", False
    vState.Add "IntervalMS", pIntervalMS

    Set CreateClockState = vState
End Function

Public Sub StartSmartClock(frm As Access.Form, _
                           ByVal pControlName As String, _
                           Optional ByVal pIntervalMS As Long = 1000)
    On Error GoTo ErrorHandler

    EnsureClockStore

    Dim vKey As String
    Dim vState As Object

    vKey = MakeClockKey(frm)

    If gClocks.Exists(vKey) Then gClocks.Remove vKey

    Set vState = CreateClockState(frm, pControlName, pIntervalMS)
    gClocks.Add vKey, vState

    frm.TimerInterval = pIntervalMS

    If gAccessHwnd = 0 Then gAccessHwnd = Application.hWndAccessApp

    If gHook = 0 Then
        gHook = SetWinEventHook( _
                    EVENT_SYSTEM_FOREGROUND, _
                    EVENT_SYSTEM_FOREGROUND, _
                    0, _
                    AddressOf ForegroundChangedProc, _
                    0, 0, _
                    WINEVENT_OUTOFCONTEXT)
    End If

    Exit Sub
ErrorHandler:
End Sub

Public Sub StopSmartClock(frm As Access.Form)
    On Error Resume Next

    EnsureClockStore

    Dim vKey As String
    vKey = MakeClockKey(frm)

    frm.TimerInterval = 0

    If gClocks.Exists(vKey) Then
        gClocks.Remove vKey
    End If

    If gClocks.Count = 0 Then
        If gHook <> 0 Then
            UnhookWinEvent gHook
            gHook = 0
        End If
        Set gClocks = Nothing
    End If
End Sub

Public Sub SmartClockTimer(frm As Access.Form)
    On Error Resume Next

    EnsureClockStore

    Dim vKey As String
    Dim vState As Object

    vKey = MakeClockKey(frm)
    If Not gClocks.Exists(vKey) Then Exit Sub

    Set vState = gClocks(vKey)

    If IsVbeOpen() Then
        vState("WasStoppedByVBE") = True
        frm.TimerInterval = 0
        Exit Sub
    End If

    Dim vTimeText As String
    vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM")

    If Len(vState("ControlName")) > 0 Then
        UpdateControlDisplay frm, vState("ControlName"), vTimeText
    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

Private Sub UpdateControlDisplay(frm As Access.Form, ByVal pControlName As String, ByVal pDisplayText As String)
    On Error Resume Next

    Dim vControl As Access.Control
    Set vControl = frm.Controls(pControlName)
    If vControl Is Nothing Then Exit Sub

    Select Case vControl.ControlType
        Case acTextBox
            If vControl.Value <> pDisplayText Then
                vControl.Value = pDisplayText
            End If
        Case acLabel
            If vControl.Caption <> pDisplayText Then
                vControl.Caption = pDisplayText
            End If
    End Select
End Sub

Private Function GetSubformControlName(vParentForm As Access.Form, vChildForm As Access.Form) As String
    On Error Resume Next

    Dim vControl As Access.Control

    For Each vControl In vParentForm.Controls
        If vControl.ControlType = acSubform Then
            If vControl.Form Is vChildForm Then
                GetSubformControlName = vControl.Name
                Exit Function
            End If
        End If
    Next vControl
End Function

Private Function GetStateTargetForm(vState As Object, ByRef vForm As Access.Form) As Boolean
    On Error GoTo ErrorHandler

    If vState("IsSubform") Then
        If (SysCmd(acSysCmdGetObjectState, acForm, vState("ParentFormName")) And acObjStateOpen) = 0 Then Exit Function
        Set vForm = Forms(vState("ParentFormName")).Controls(vState("SubformControlName")).Form
    Else
        If (SysCmd(acSysCmdGetObjectState, acForm, vState("HostFormName")) And acObjStateOpen) = 0 Then Exit Function
        Set vForm = Forms(vState("HostFormName"))
    End If

    GetStateTargetForm = Not (vForm Is Nothing)
    Exit Function
ErrorHandler:
    Set vForm = Nothing
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 gClocks Is Nothing Then Exit Sub
    If gClocks.Count = 0 Then Exit Sub
    If GetAncestor(hwnd, GA_ROOT) <> gAccessHwnd Then Exit Sub

    Dim vKey As Variant
    Dim vState As Object
    Dim vForm As Access.Form

    For Each vKey In gClocks.Keys
        Set vState = gClocks(vKey)

        If vState("WasStoppedByVBE") Then
            If GetStateTargetForm(vState, vForm) Then
                vForm.TimerInterval = vState("IntervalMS")

                Dim vTimeText As String
                vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM")

                If Len(vState("ControlName")) > 0 Then
                    UpdateControlDisplay vForm, vState("ControlName"), vTimeText
                End If

                vState("WasStoppedByVBE") = False
            End If
        End If
    Next vKey
End Sub

Private Sub Form_Load()
    Application.Run "StartSmartClock", Me, "lblTime", 1000
End Sub

Private Sub Form_Timer()
    Application.Run "SmartClockTimer", Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Application.Run "StopSmartClock", Me
End Sub

Private Sub Form_Load()
    Application.Run "StartSmartClock", Me, "txtTime", 1000
End Sub

Private Sub Form_Timer()
    Application.Run "SmartClockTimer", Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Application.Run "StopSmartClock", Me
End Sub

Private Sub Form_Load()
    Application.Run "StartSmartClock", Me, "", 1000
End Sub

Private Sub Form_Timer()
    Application.Run "SmartClockTimer", Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Application.Run "StopSmartClock", Me
End Sub

Application.Run "StartSmartClock", Me, "", 1000

' الطريقة الأولى: تمرير قيمة مخصصة (مثلاً نصف ثانية)
Application.Run "StartSmartClock", Me, "lblTime", 500

' الطريقة الثانية: حذف المعامل (يتم استخدام 1000 تلقائياً)
Application.Run "StartSmartClock", Me, "lblTime"

Option Compare Database
Option Explicit

Private mIsSmartClockActive As Boolean

Private Sub Form_Load()
    AttemptStartSmartClock
End Sub

Private Sub Form_Timer()
    Dim vTimeText As String
    vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM")
    
    If mIsSmartClockActive Then
        Application.Run "SmartClockTimer", Me
        Me.txtDClock = vTimeText
    Else
        ' Fallback: النموذج يحدث نفسه بنفسه
        Me.txtDClock = vTimeText
        Me.lblDClock.Caption = vTimeText
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If mIsSmartClockActive Then
        Application.Run "StopSmartClock", Me
    End If
    Me.TimerInterval = 0
    On Error GoTo 0
End Sub

Private Sub AttemptStartSmartClock()
    On Error GoTo FallbackMode
    Application.Run "StartSmartClock", Me, "lblDClock", 1000
    mIsSmartClockActive = True
    Exit Sub
    
FallbackMode:
    Err.Clear
    mIsSmartClockActive = False
    Me.TimerInterval = 1000
End Sub

LabelStartSmartClock Me, "lblTime"

StartSmartClock Me, "txtTime"

StartSmartClock Me, ""