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

[ابو جودي]

الوحده النمطية الأولى: bas01:TimeAction

المميزات

•  أنواع أحداث وتعليقات قابلة للتوسعة عبر Enum (EventType, ControlVisibility)
•  تحديد توقيت إظهار/إخفاء عناصر النماذج بسهولة عبر الدالة SetControlVisibility
•  تنفيذ إجراءات مؤقتة باستخدام CallTimeAction أو ApplyTimeActions
•  منع التكرار التلقائي للتنفيذ بالدالة الذكية ExecuteDynamicMethod
•  دعم المعاملات وتعددها في الدوال المنفذة (حتى 4 معاملات)
•  تسجيل احترافي للأحداث عبر LogEvent في نافذة Immediate شرط تفعيل DebugMode

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

استخدم الكود فى الحالات الآتيـــة :

• إذا كنت تحتاج إلى تنفيذ إجراءات زمنية عادية ومكررة يوميا

• إذا كنت لا تمانع في تنفيذ نفس الدالة مرات مختلفة إذا تغيّر التوقيت 

Option Compare Database
Option Explicit

' =========================
' إعدادات عامة
' =========================
Public DebugMode As Boolean
Private dicExecuted As Object ' لتجنب تكرار التنفيذ

' =========================
' أنواع الأحداث والمظهر
' =========================
Public Enum ControlVisibility
    visible = 0
    Hidden = 1
    ErrorState = 2
End Enum

Public Enum EventType
    Information = 0
    Warning = 1
    [Error] = 2
End Enum

' =========================
' تهيئة الوحدة
' =========================
Private Sub InitializeModule()
    If dicExecuted Is Nothing Then
        Set dicExecuted = CreateObject("Scripting.Dictionary")
        dicExecuted.CompareMode = vbTextCompare
    End If
End Sub

' =========================
' إعادة تعيين السجل
' =========================
Public Sub ResetExecutedLog()
    If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll
End Sub

' =========================
' أدوات مساعدة عامة
' =========================
Public Sub LogEvent(message As String, Optional msgType As EventType = Information)
    If DebugMode Then
        Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedAction] " & _
                    Choose(msgType + 1, "INFO", "WARN", "ERR") & ": " & message
    End If
End Sub

Private Function IsFormName(ByVal varValue As Variant) As Boolean
    On Error GoTo ErrHandler
    If VBA.TypeName(varValue) = "String" Then
        If SysCmd(acSysCmdGetObjectState, acForm, CStr(varValue)) = acObjStateOpen Then
            IsFormName = True
        End If
    End If
    Exit Function
ErrHandler:
    IsFormName = False
End Function

Private Function IsString(v As Variant) As Boolean
    IsString = (VarType(v) = vbString)
End Function

Private Function IsBoolean(v As Variant) As Boolean
    IsBoolean = (VarType(v) = vbBoolean)
End Function

Private Function IsObject(v As Variant) As Boolean
    IsObject = (VarType(v) >= vbObject)
End Function

Public Function ShouldShowControl(Optional TargetTime As Date = #3:00:00 PM#) As Boolean
    ShouldShowControl = (Time() < TargetTime)
End Function

Public Function SetControlVisibility(frm As Form, ctlName As String, _
                                    Optional TargetTime As Date = #3:00:00 PM#) As ControlVisibility
    On Error GoTo ErrorHandler

    If frm Is Nothing Or Len(Trim(ctlName)) = 0 Then
        LogEvent "النموذج أو اسم العنصر غير صالح في SetControlVisibility", [Error]
        SetControlVisibility = ErrorState
        Exit Function
    End If

    Dim ctl As Control
    Set ctl = frm.Controls(ctlName)

    If ctl Is Nothing Then
        LogEvent "العنصر '" & ctlName & "' غير موجود في النموذج", [Error]
        SetControlVisibility = ErrorState
        Exit Function
    End If

    Dim bolVisible As Boolean
    bolVisible = ShouldShowControl(TargetTime)
    ctl.visible = bolVisible
    SetControlVisibility = IIf(bolVisible, visible, Hidden)
    Exit Function

ErrorHandler:
    LogEvent "خطأ في SetControlVisibility للعنصر '" & ctlName & "': " & Err.Description, [Error]
    SetControlVisibility = ErrorState
End Function

' =========================
' تنفيذ ذكي للدوال
' =========================
Private Sub ExecuteDynamicMethod(ByVal objTarget As Object, ByVal strMethodName As String, Optional arrArgs As Variant)
    On Error GoTo HandleError

    InitializeModule
    If Len(Trim(strMethodName)) = 0 Then
        LogEvent "اسم الدالة فارغ في ExecuteDynamicMethod", [Error]
        Exit Sub
    End If

    If dicExecuted.Exists(strMethodName) Then
        LogEvent "الدالة '" & strMethodName & "' تم تنفيذها مسبقاً", Warning
        Exit Sub
    End If

    If Not objTarget Is Nothing Then
        If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then
            CallByName objTarget, strMethodName, VbMethod
        Else
            ExecuteWithParams objTarget, strMethodName, arrArgs
        End If
    Else
        If IsMissing(arrArgs) Or IsEmpty(arrArgs) Then
            Application.Run strMethodName
        Else
            ExecuteRunWithParams strMethodName, arrArgs
        End If
    End If

    dicExecuted(strMethodName) = True
    LogEvent "تم تنفيذ '" & strMethodName & "' بنجاح", Information
    Exit Sub

HandleError:
    LogEvent "خطأ في تنفيذ '" & strMethodName & "': " & Err.Number & " - " & Err.Description, [Error]
End Sub

Private Sub ExecuteWithParams(objTarget As Object, strMethodName As String, params As Variant)
    On Error GoTo HandleError

    Dim paramCount As Long, i As Long
    Dim tempParams() As Variant

    If IsArray(params) Then
        paramCount = UBound(params) + 1
        ReDim tempParams(paramCount - 1)
        For i = 0 To paramCount - 1
            If IsFormName(params(i)) Then
                Set tempParams(i) = Forms(params(i))
            Else
                tempParams(i) = params(i)
            End If
            LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information
        Next
    Else
        paramCount = 1
        ReDim tempParams(0)
        tempParams(0) = params
        LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information
    End If

    Select Case paramCount
        Case 0: CallByName objTarget, strMethodName, VbMethod
        Case 1: CallByName objTarget, strMethodName, VbMethod, tempParams(0)
        Case 2: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1)
        Case 3: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2)
        Case 4: CallByName objTarget, strMethodName, VbMethod, tempParams(0), tempParams(1), tempParams(2), tempParams(3)
        Case Else
            LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في CallByName لـ '" & strMethodName & "'", [Error]
    End Select
    Exit Sub

HandleError:
    LogEvent "خطأ في ExecuteWithParams لـ '" & strMethodName & "': " & Err.Description, [Error]
End Sub

Private Sub ExecuteRunWithParams(strMethodName As String, params As Variant)
    On Error GoTo HandleError

    Dim paramCount As Long, i As Long
    Dim tempParams() As Variant

    If IsArray(params) Then
        paramCount = UBound(params) + 1
        ReDim tempParams(paramCount - 1)
        For i = 0 To paramCount - 1
            If IsFormName(params(i)) Then
                Set tempParams(i) = Forms(params(i))
            Else
                tempParams(i) = params(i)
            End If
            LogEvent "معامل " & i & " لـ '" & strMethodName & "': " & CStr(tempParams(i)), Information
        Next
    Else
        paramCount = 1
        ReDim tempParams(0)
        tempParams(0) = params
        LogEvent "معامل 0 لـ '" & strMethodName & "': " & CStr(tempParams(0)), Information
    End If

    Select Case paramCount
        Case 0: Application.Run strMethodName
        Case 1: Application.Run strMethodName, tempParams(0)
        Case 2: Application.Run strMethodName, tempParams(0), tempParams(1)
        Case 3: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2)
        Case 4: Application.Run strMethodName, tempParams(0), tempParams(1), tempParams(2), tempParams(3)
        Case Else
            LogEvent "عدد المعاملات أكثر من 4 غير مدعوم في Application.Run لـ '" & strMethodName & "'", [Error]
    End Select
    Exit Sub

HandleError:
    LogEvent "خطأ في ExecuteRunWithParams لـ '" & strMethodName & "': " & Err.Description, [Error]
End Sub

' =========================
' التحقق من توقيت التنفيذ
' =========================
Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean
    Dim dtmNow As Date: dtmNow = Time()
    If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then
        IsTimeMatch = (dtmNow >= dtmStart)
    Else
        IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd)
    End If
End Function

' =========================
' تنفيذ الإجراءات المؤقتة
' =========================
Public Sub CallTimeAction(ByVal objTarget As Object, ByVal strMethodName As String, _
                          ByVal dtmStart As Date, Optional ByVal dtmEnd As Variant, _
                          Optional ByVal bolUseRange As Boolean = True)
    On Error Resume Next
    If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then
        ExecuteDynamicMethod objTarget, strMethodName
    End If
End Sub

Public Sub CallTimeActionWithArgs(ByVal objTarget As Object, ByVal strMethodName As String, _
                                  ByVal arrArgs As Variant, ByVal dtmStart As Date, _
                                  Optional ByVal dtmEnd As Variant, _
                                  Optional ByVal bolUseRange As Boolean = True)
    On Error Resume Next
    If IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then
        ExecuteDynamicMethod objTarget, strMethodName, arrArgs
    End If
End Sub

Public Sub ApplyTimeActions(ByVal objTarget As Object, ByVal arrActions As Variant)
    InitializeModule
    Dim arrItem As Variant
    For Each arrItem In arrActions
        If Not IsArray(arrItem) Then
            LogEvent "العنصر في arrActions ليس مصفوفة صالحة", [Error]
            GoTo ContinueLoop
        End If

        Dim strMethod As String: strMethod = arrItem(0)
        Dim lngUB As Long: lngUB = UBound(arrItem)
        Dim arrArgs As Variant: arrArgs = Empty
        Dim dtmStart As Date
        Dim dtmEnd As Variant: dtmEnd = Null
        Dim bolUseRange As Boolean: bolUseRange = True

        If lngUB < 1 Then
            LogEvent "بيانات غير كافية للإجراء '" & strMethod & "'", [Error]
            GoTo ContinueLoop
        End If

        If IsArray(arrItem(1)) Then
            arrArgs = arrItem(1)
            dtmStart = arrItem(2)
            If lngUB >= 3 Then dtmEnd = arrItem(3)
            If lngUB >= 4 Then bolUseRange = arrItem(4)
            ' فحص المعاملات
            If strMethod = "HideControlByName" And UBound(arrArgs) >= 0 Then
                If Not IsString(arrArgs(0)) Then
                    LogEvent "معامل HideControlByName ليس سلسلة نصية: " & CStr(arrArgs(0)), [Error]
                    GoTo ContinueLoop
                End If
            ElseIf strMethod = "ComplexMsgBox" And UBound(arrArgs) >= 2 Then
                If Not IsString(arrArgs(0)) Or Not IsBoolean(arrArgs(1)) Or Not IsObject(arrArgs(2)) Then
                    LogEvent "معاملات ComplexMsgBox غير صالحة: " & Join(arrArgs, ","), [Error]
                    GoTo ContinueLoop
                End If
            ElseIf strMethod = "LocalMsg" And UBound(arrArgs) >= 1 Then
                If Not IsString(arrArgs(0)) Or Not IsString(arrArgs(1)) Then
                    LogEvent "معاملات LocalMsg غير صالحة: " & Join(arrArgs, ","), [Error]
                    GoTo ContinueLoop
                End If
            End If
            CallTimeActionWithArgs objTarget, strMethod, arrArgs, dtmStart, dtmEnd, bolUseRange
        Else
            dtmStart = arrItem(1)
            If lngUB >= 2 Then dtmEnd = arrItem(2)
            If lngUB >= 3 Then bolUseRange = arrItem(3)
            CallTimeAction objTarget, strMethod, dtmStart, dtmEnd, bolUseRange
        End If
ContinueLoop:
    Next
End Sub

' =========================
' مثال استخدام ComplexMsgBox
' =========================
Public Sub ComplexMsgBox(ByVal strVal As String, ByVal bolFlag As Boolean, ByVal frm As Form)
    If bolFlag Then
        MsgBox "تم تنفيذ الإجراء على النموذج: " & frm.Name & " باستخدام القيمة: " & strVal
    End If
End Sub

--------------------------
الوحده النمطية الثانية : bas02:TimeExecutionKeyed

المميزات

 

• تنفيذ ذكي مشروط بالوقت باستخدام TimedRunWithKey
• منع التكرار التام بفضل المفتاح الفريد (ExecutionKey)
• تعامل مرن مع الإجراءات بحد أقصى 4 معاملات
• بناء مفتاح فريد يجمع اسم الدالة والمعاملات والتوقيت

 

 

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

استخدم الكود فى الحالات الآتيـــة :

• إذا كنت تريد ضمان عدم تكرار نفس الإجراء بنفس الظروف بشكل صارم (مثل تسجيل حركة مرة واحدة فقط لكل توقيت)

• إذا كنت تحتاج تتبع وتنفيذ ذكي مبني على مفتاح فريد

Option Compare Database
Option Explicit

Private dicExecuted As Object

' ========== التهيئة ==========
Private Sub InitializeModule()
    If dicExecuted Is Nothing Then
        Set dicExecuted = CreateObject("Scripting.Dictionary")
        dicExecuted.CompareMode = vbTextCompare
    End If
End Sub

Public Sub ResetExecutedLog()
    If Not dicExecuted Is Nothing Then dicExecuted.RemoveAll
End Sub

' ========== أدوات مساعدة ==========
Private Function ToSafeString(val As Variant) As String
    If IsObject(val) Then
        On Error Resume Next
        ToSafeString = TypeName(val)
        Exit Function
    End If
    If IsNull(val) Then
        ToSafeString = "<NULL>"
    Else
        ToSafeString = CStr(val)
    End If
End Function

Private Function BuildExecutionKey(ByVal strMethod As String, ByVal arrArgs As Variant, _
                                   ByVal dtmStart As Date, ByVal dtmEnd As Variant) As String
    Dim arrParts() As String
    Dim i As Long

    ReDim arrParts(0)
    arrParts(0) = strMethod

    If IsArray(arrArgs) Then
        For i = 0 To UBound(arrArgs)
            ReDim Preserve arrParts(UBound(arrParts) + 1)
            arrParts(UBound(arrParts)) = ToSafeString(arrArgs(i))
        Next
    ElseIf Not IsMissing(arrArgs) Then
        ReDim Preserve arrParts(UBound(arrParts) + 1)
        arrParts(UBound(arrParts)) = ToSafeString(arrArgs)
    End If

    ReDim Preserve arrParts(UBound(arrParts) + 1)
    arrParts(UBound(arrParts)) = Format(dtmStart, "hh:nn:ss")

    If Not IsMissing(dtmEnd) And Not IsNull(dtmEnd) Then
        ReDim Preserve arrParts(UBound(arrParts) + 1)
        arrParts(UBound(arrParts)) = Format(dtmEnd, "hh:nn:ss")
    End If

    BuildExecutionKey = Join(arrParts, "|")
End Function

Private Function AlreadyExecuted(strExecKey As String) As Boolean
    AlreadyExecuted = dicExecuted.Exists(strExecKey)
End Function

Private Sub MarkExecuted(strExecKey As String)
    dicExecuted(strExecKey) = True
End Sub

Private Sub Log(ByVal msg As String, Optional msgType As String = "INFO")
    If DebugMode Then Debug.Print Format(Now, "yyyy-mm-dd hh:nn:ss") & " [TimedActionKey] " & msgType & ": " & msg
End Sub

Private Function IsTimeMatch(ByVal dtmStart As Date, ByVal dtmEnd As Variant, ByVal bolUseRange As Boolean) As Boolean
    Dim dtmNow As Date: dtmNow = Time()
    If IsMissing(dtmEnd) Or IsNull(dtmEnd) Or Not bolUseRange Then
        IsTimeMatch = (dtmNow >= dtmStart)
    Else
        IsTimeMatch = (dtmNow >= dtmStart And dtmNow <= dtmEnd)
    End If
End Function

Private Sub RunWithArgs(ByVal objTarget As Object, ByVal strMethod As String, arrArgs As Variant)
    On Error GoTo HandleError
    If objTarget Is Nothing Then
        Select Case UBound(arrArgs)
            Case 0: Application.Run strMethod, arrArgs(0)
            Case 1: Application.Run strMethod, arrArgs(0), arrArgs(1)
            Case 2: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2)
            Case 3: Application.Run strMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3)
            Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR"
        End Select
    Else
        Select Case UBound(arrArgs)
            Case 0: CallByName objTarget, strMethod, VbMethod, arrArgs(0)
            Case 1: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1)
            Case 2: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2)
            Case 3: CallByName objTarget, strMethod, VbMethod, arrArgs(0), arrArgs(1), arrArgs(2), arrArgs(3)
            Case Else: Log "أكثر من 4 معاملات غير مدعومة لـ " & strMethod, "ERR"
        End Select
    End If
    Exit Sub

HandleError:
    Log "خطأ في تنفيذ " & strMethod & ": " & Err.Number & " - " & Err.Description, "ERR"
End Sub

' ========== الدالة الرئيسية ==========
Public Sub TimedRunWithKey(ByVal objTarget As Object, ByVal strMethod As String, _
                           ByVal arrArgs As Variant, ByVal dtmStart As Date, _
                           Optional ByVal dtmEnd As Variant, _
                           Optional ByVal bolUseRange As Boolean = True)
    InitializeModule
    If Not IsTimeMatch(dtmStart, dtmEnd, bolUseRange) Then Exit Sub

    Dim strKey As String
    strKey = BuildExecutionKey(strMethod, arrArgs, dtmStart, dtmEnd)

    If AlreadyExecuted(strKey) Then
        Log "تخطي التنفيذ المكرر لـ " & strMethod, "WARN"
        Exit Sub
    End If

    RunWithArgs objTarget, strMethod, arrArgs
    MarkExecuted strKey
    Log "تم التنفيذ بـ Key: " & strKey
End Sub



' For Tesr
Public Sub TestMsgProc(ByVal strMsg As String, ByVal bolShow As Boolean)
    If bolShow Then
        MsgBox "تم التنفيذ: " & strMsg, vbInformation, "اختبار"
    Else
        Debug.Print "? تم تجاهل الإظهار ولكن التنفيذ تم: " & strMsg
    End If
End Sub

وأخيرا المرفق

TimedAction.accdb

[Lamyaa]

دائما مبدع .. وبأفكار جديدة

شكرا يا أبا جودي 

[عمر ضاحى]

ياخي المبدع مبدع برضه 

معلم 

يا معلم 😁

تسلم ايدك يا معلم ^_^