الرسائل المؤقتة (tempMsgBox) مع ميزة تفعيل الزر الإفتراضي عند إنتهاء المدة المحددة

[Ahmos]

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

الأخوة الكرام تحية طيبة وبعد ،،،

تقوم الفكرة علي ضبط وقت محدد للرسائل وإتاحة فرصة للمستخدم لإتخاذ القرار
وعند إنتهاء المدة المحددة يتم إعتماد الزر الإفتراضي
 

الوظيفة : tempMsgBox
فقط نزيد temp علي الـ MsgBox العادية وتستخدم نفس الإستخدام ونضيف فقط المدة لمحددة (الوقت الإفتراضي هو 5 ثواني)

الكود كامل بالأمثلة
 

Option Compare Database
Option Explicit

'----------------------------------------------------------------------------------------------------------
' Module    : AWS_Temp_MessageBox
' Author    : Original: Collected over the internet I don't remember
'             Enhanced: Ahmos - The Last Egyptian King
' Email     : Phoronex@yahoo.com
' Purpose   : Provides customizable message boxes with automatic timeout and default actions
' Copyright : © 2024 Ahmos. Released under Attribution 4.0 International
'             (CC BY 4.0) - https://creativecommons.org/licenses/by/4.0/
'
' Usage:
' ~~~~~~
' result = tempMsgBox("Message", vbOKOnly)                      ' Basic message box
' result = tempMsgBox("Message", vbYesNo, "Title", 5000)        ' Custom timeout message box
' result = tempMsgBox("Continue?", vbYesNo + vbDefaultButton2)  ' Default No after timeout
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
'----------------------------------------------------------------------------------------------------------
' 1         Unknown                 Initial version with basic MessageBoxTimeoutA API
' 2         2024-11-01              Enhanced version:
'                                    - Added input validation
'                                    - Enhanced error handling
'                                    - Added timeout management
'                                    - Added default action handling
'                                    - Added comprehensive documentation
' 3         2024-11-02              Remapping the default button style based on the number of buttons
'                                    - All Credits TO ( https://claude.ai)
'----------------------------------------------------------------------------------------------------------
' Functions:
' ~~~~~~~~~~
' tempMsgBox            : Main function for displaying timeout message boxes
' GetDefaultButtonStyle : Helper function for determining default buttons
' ValidateTimeout       : Validates timeout parameters
' ValidateButtons       : Validates button combinations
'
' Dependencies:
' ~~~~~~~~~~~~
' - Windows API (user32.dll)
' - VBA7 for 64-bit support
'
' Notes:
' ~~~~~~
' - Supports all standard VBA message box button combinations
' - Automatic timeout with configurable duration
' - Default action handling on timeout
' - 32/64-bit compatible using conditional compilation
' - Enhanced error handling with custom error codes
'----------------------------------------------------------------------------------------------------------
'        **-----**_______________{]___________________________________________________________
'        {&&&&&&&#%%&#%&%&%&%&%#%&|]__________________________The Last Egyptian King___________\
'                                  {]
'----------------------------------------------------------------------------------------------------------

' Constants
Private Const DEFAULT_TIMEOUT_MILLISECONDS As Long = 5000
Private Const MINIMUM_TIMEOUT_MILLISECONDS As Long = 1000
Private Const MAXIMUM_TIMEOUT_MILLISECONDS As Long = 300000  ' 5 minutes

#If VBA7 Then
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" ( _
        ByVal hwnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As VbMsgBoxStyle, _
        ByVal wlange As Long, _
        ByVal dwTimeout As Long _
    ) As Long
#Else
    Private Declare Function MessageBoxTimeoutA Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal wType As VbMsgBoxStyle, _
        ByVal wlange As Long, _
        ByVal dwTimeout As Long _
    ) As Long
#End If

'/// Custom Error Constants
Private Const ERROR_INVALID_TIMEOUT As Long = vbObjectError + 1000
Private Const ERROR_INVALID_BUTTONS As Long = vbObjectError + 1001

'/// Enumerations
Public Enum TempMsgBoxTimeoutResult
    VbTimeout = 32000
End Enum

'/// Function: ValidateTimeout
'/// Validates the timeout value is within acceptable range
'/// @param timeoutMs - Timeout value in milliseconds
'/// @returns Boolean - True if valid, False if invalid
Private Function ValidateTimeout(ByVal timeoutMs As Long) As Boolean
    ValidateTimeout = (timeoutMs >= MINIMUM_TIMEOUT_MILLISECONDS And timeoutMs <= MAXIMUM_TIMEOUT_MILLISECONDS)
End Function

'/// Function: ValidateButtons
'/// Validates the message box buttons combination
'/// @param buttons - VbMsgBoxStyle value for buttons
'/// @returns Boolean - True if valid, False if invalid
Private Function ValidateButtons(ByVal buttons As VbMsgBoxStyle) As Boolean
    Dim validButtonCombos As Variant
    validButtonCombos = Array(vbOKOnly, vbOKCancel, vbYesNo, vbYesNoCancel, vbRetryCancel, vbAbortRetryIgnore)
    
    Dim baseButtons As VbMsgBoxStyle
    baseButtons = buttons And 7  ' Get only the buttons part
    
    Dim i As Long
    For i = LBound(validButtonCombos) To UBound(validButtonCombos)
        If baseButtons = validButtonCombos(i) Then
            ValidateButtons = True
            Exit Function
        End If
    Next i
    
    ValidateButtons = False
End Function

'/// Function: msgBtnRemapping
'/// Remapping the default button style based on the number of buttons
'/// @param msgButtons - Button combination (e.g., vbYesNo, vbAbortRetryIgnore)
'/// @param defaultButton - The requested default button style
'/// @returns VbMsgBoxStyle - The normalized default button style
Private Function msgBtnRemapping(ByVal msgButtons As VbMsgBoxStyle, ByVal defaultButton As VbMsgBoxStyle) As VbMsgBoxStyle
    ' Get only the basic button combination (strip other flags)
    Dim baseButtons As VbMsgBoxStyle
    baseButtons = msgButtons And 7
    
    ' For two-button combinations
    If baseButtons = vbYesNo Or baseButtons = vbRetryCancel Or baseButtons = vbOKCancel Then
        Select Case defaultButton And &HF00    ' Mask to get only default button bits
            Case vbDefaultButton3  ' Equivalent to Button1
                msgBtnRemapping = (msgButtons And Not &HF00) Or vbDefaultButton1
'                Debug.Print "Two buttons: Changed DB3 to DB1"
            Case vbDefaultButton4  ' Equivalent to Button2
                msgBtnRemapping = (msgButtons And Not &HF00) Or vbDefaultButton2
'                Debug.Print "Two buttons: Changed DB4 to DB2"
            Case Else
                msgBtnRemapping = msgButtons
'                Debug.Print "Two buttons: No change needed"
        End Select
    
    ' For three-button combinations
    ElseIf baseButtons = vbAbortRetryIgnore Or baseButtons = vbYesNoCancel Then
        Select Case defaultButton And &HF00    ' Mask to get only default button bits
            Case vbDefaultButton4  ' Equivalent to Button2
                msgBtnRemapping = (msgButtons And Not &HF00) Or vbDefaultButton2
'                Debug.Print "Three buttons: Changed DB4 to DB2"
            Case Else
                msgBtnRemapping = msgButtons
'                Debug.Print "Three buttons: No change needed"
        End Select
    
    ' For single-button combinations (vbOKOnly)
    Else
        msgBtnRemapping = (msgButtons And Not &HF00) Or vbDefaultButton1
'        Debug.Print "Single button: Set to DB1"
    End If
End Function

'/// Function: GetDefaultButtonStyle
'/// Determines and validates the default button style
'/// @param msgButtons - VbMsgBoxStyle value for buttons
'/// @returns VbMsgBoxStyle - The normalized button style
Private Function GetDefaultButtonStyle(ByVal msgButtons As VbMsgBoxStyle) As VbMsgBoxStyle
'    Debug.Print "Original buttons: " & msgButtons
    
    ' Apply Button Remapping
    Dim reMappedButtons As VbMsgBoxStyle
    reMappedButtons = msgBtnRemapping(msgButtons, msgButtons)
    
'    Debug.Print "ReMapped buttons: " & reMappedButtons
    GetDefaultButtonStyle = reMappedButtons
End Function


'/// Function: GetTimeoutDefaultValue
'/// Determines the default value to return when timeout occurs
'/// @param msgButtons - Button style of the message box
'/// @param defaultButtonStyle - Default button style
'/// @returns VbMsgBoxResult - The default value to return
Private Function GetTimeoutDefaultValue(ByVal msgButtons As VbMsgBoxStyle, ByVal defaultButtonStyle As VbMsgBoxStyle) As VbMsgBoxResult
    ' Get only buttons information
    msgButtons = msgButtons And 7
    
    Select Case msgButtons
        Case vbYesNo
            Select Case defaultButtonStyle
                Case vbDefaultButton1: GetTimeoutDefaultValue = vbYes
                Case vbDefaultButton2: GetTimeoutDefaultValue = vbNo
                Case vbDefaultButton3: GetTimeoutDefaultValue = vbYes
                Case vbDefaultButton4: GetTimeoutDefaultValue = vbNo
                Case Else: GetTimeoutDefaultValue = vbYes
            End Select
            
        Case vbYesNoCancel
            Select Case defaultButtonStyle
                Case vbDefaultButton1: GetTimeoutDefaultValue = vbYes
                Case vbDefaultButton2: GetTimeoutDefaultValue = vbNo
                Case vbDefaultButton3: GetTimeoutDefaultValue = vbCancel
                Case vbDefaultButton4: GetTimeoutDefaultValue = vbNo
                Case Else: GetTimeoutDefaultValue = vbYes
            End Select
            
        Case vbAbortRetryIgnore
            Select Case defaultButtonStyle
                Case vbDefaultButton1: GetTimeoutDefaultValue = vbAbort
                Case vbDefaultButton2: GetTimeoutDefaultValue = vbRetry
                Case vbDefaultButton3: GetTimeoutDefaultValue = vbIgnore
                Case vbDefaultButton4: GetTimeoutDefaultValue = vbRetry
                Case Else: GetTimeoutDefaultValue = vbAbort
            End Select
            
        Case vbRetryCancel
            Select Case defaultButtonStyle
                Case vbDefaultButton1: GetTimeoutDefaultValue = vbRetry
                Case vbDefaultButton2: GetTimeoutDefaultValue = vbCancel
                Case vbDefaultButton3: GetTimeoutDefaultValue = vbRetry
                Case vbDefaultButton4: GetTimeoutDefaultValue = vbCancel
                Case Else: GetTimeoutDefaultValue = vbRetry
            End Select
            
        Case vbOKCancel
            Select Case defaultButtonStyle
                Case vbDefaultButton1: GetTimeoutDefaultValue = vbOK
                Case vbDefaultButton2: GetTimeoutDefaultValue = vbCancel
                Case vbDefaultButton3: GetTimeoutDefaultValue = vbOK
                Case vbDefaultButton4: GetTimeoutDefaultValue = vbCancel
                Case Else: GetTimeoutDefaultValue = vbOK
            End Select
            
        Case vbOKOnly
            GetTimeoutDefaultValue = vbOK
        Case Else
            GetTimeoutDefaultValue = TempMsgBoxTimeoutResult.VbTimeout
            
    End Select
End Function

'/// Function: tempMsgBox
'/// Displays a message box that automatically closes after a specified timeout
'/// @param msgText - The message to display
'/// @param msgButtons - Button combination to display (optional)
'/// @param msgTitle - Title of the message box (optional)
'/// @param msgTimeoutMilliseconds - Timeout in milliseconds (optional)
'/// @returns VbMsgBoxResult - The result of the message box
Public Function tempMsgBox( _
        ByVal msgText As String, _
        Optional ByVal msgButtons As VbMsgBoxStyle = vbOKOnly, _
        Optional ByVal msgTitle As String = vbNullString, _
        Optional ByVal msgTimeoutMilliseconds As Long = DEFAULT_TIMEOUT_MILLISECONDS) As VbMsgBoxResult
    
    On Error GoTo ErrorHandler
    
'    Debug.Print String(50, "-")
'    Debug.Print "tempMsgBox called with buttons: " & msgButtons
    
    ' Input validation
    If Not ValidateTimeout(msgTimeoutMilliseconds) Then
        Err.Raise ERROR_INVALID_TIMEOUT, "tempMsgBox", _
            "Timeout must be between " & MINIMUM_TIMEOUT_MILLISECONDS & _
            " and " & MAXIMUM_TIMEOUT_MILLISECONDS & " milliseconds"
    End If
    
    If Not ValidateButtons(msgButtons) Then
        Err.Raise ERROR_INVALID_BUTTONS, "tempMsgBox", _
            "Invalid button combination specified"
    End If
    
    ' Get normalized button style
    Dim finalMsgButtons As VbMsgBoxStyle
    finalMsgButtons = GetDefaultButtonStyle(msgButtons)
    
'    Debug.Print "Final buttons before API call: " & finalMsgButtons
    
    ' Call the MessageBoxTimeoutA API function
    tempMsgBox = MessageBoxTimeoutA(Application.hWndAccessApp, _
                                   msgText, _
                                   msgTitle, _
                                   finalMsgButtons, _
                                   0, _
                                   msgTimeoutMilliseconds)
    
'    Debug.Print "API returned: " & tempMsgBox
    
    ' Handle timeout case
    If tempMsgBox = TempMsgBoxTimeoutResult.VbTimeout Then
        tempMsgBox = GetTimeoutDefaultValue(msgButtons, (finalMsgButtons And &HF00))
'        Debug.Print "Timeout occurred, using default value: " & tempMsgBox
    End If
    
    Exit Function
    
ErrorHandler:
    Debug.Print "Error occurred: " & Err.Number & " - " & Err.Description
    Select Case Err.Number
        Case ERROR_INVALID_TIMEOUT, ERROR_INVALID_BUTTONS
            MsgBox "Configuration Error: " & Err.Description, _
                   vbCritical, _
                   "tempMsgBox Error"
        Case Else
            MsgBox "An unexpected error occurred: " & vbNewLine & _
                   "Error " & Err.Number & ": " & Err.Description, _
                   vbCritical, _
                   "tempMsgBox Error"
    End Select
    tempMsgBox = vbCancel
End Function

Public Sub printUserChoice(lResult As Long)
    Select Case lResult
        Case vbAbort
            Debug.Print "User clicked Abort", lResult
        Case vbRetry
            Debug.Print "User clicked Retry", lResult
        Case vbIgnore
            Debug.Print "User clicked Ignore", lResult
        Case vbYes
            Debug.Print "User clicked Yes", lResult
        Case vbNo
            Debug.Print "User clicked No", lResult
        Case vbOK
            Debug.Print "User clicked OK", lResult
        Case vbCancel
            Debug.Print "User clicked Cancel", lResult
        Case Else
            Debug.Print "Unknown result", lResult
    End Select
End Sub
'/// Sub: TestTempMsgBox
'/// Test procedure demonstrating various uses of the tempMsgBox function
Public Sub TestTempMsgBox()
    Dim result As VbMsgBoxResult
    Dim msgTitle As String
    msgTitle = "Test Message"
    
    ' Test 1: Basic message with timeout
    result = tempMsgBox("This message will timeout in 3 seconds", _
                       vbInformation + vbOKOnly, _
                       msgTitle, _
                       3000)
    Debug.Print "Test 1 Result: " & result

    ' Test 2: Yes/No dialog with default No
    result = tempMsgBox("Would you like to continue?", _
                       vbQuestion + vbYesNo + vbDefaultButton2, _
                       msgTitle, _
                       5000)
    Debug.Print "Test 2 Result: " & result
    If result = vbYes Then
        Debug.Print "Action If YES"
    ElseIf result = vbNo Then
        Debug.Print "Action If NO"
    End If

    ' Test 3: Yes/No/Cancel dialog with default Cancel
    result = tempMsgBox("Confirm action", _
                       vbQuestion + vbYesNoCancel + vbDefaultButton3, _
                       msgTitle, _
                       4000)
    Debug.Print "Test 3 Result: " & result
    
    ' Test 4: Abort/Retry/Ignore with default Ignore
    result = tempMsgBox("An error occurred. Retry or Ignore?", _
                       vbExclamation + vbAbortRetryIgnore + vbDefaultButton3, _
                       msgTitle, _
                       1000)
    printUserChoice result
    
    
End Sub

Sub Test_allCases()

    Dim result      As VbMsgBoxResult
    Dim msgTitle    As String
    Dim msTime      As Long
    
    msgTitle = "Test Message"
    msTime = 1000
    
    Debug.Print "vbAbortRetryIgnore All Buttons Test Cases"
    result = tempMsgBox("An error occurred. Retry or Ignore?", _
                       vbExclamation + vbAbortRetryIgnore + vbDefaultButton1, _
                       msgTitle, _
                       msTime)
    Debug.Print "vbDefaultButton1"
    printUserChoice result
    
    result = tempMsgBox("An error occurred. Retry or Ignore?", _
                       vbExclamation + vbAbortRetryIgnore + vbDefaultButton2, _
                       msgTitle, _
                       msTime)
    Debug.Print "vbDefaultButton2"
    printUserChoice result
    
    result = tempMsgBox("An error occurred. Retry or Ignore?", _
                       vbExclamation + vbAbortRetryIgnore + vbDefaultButton3, _
                       msgTitle, _
                       msTime)
    Debug.Print "vbDefaultButton3"
    printUserChoice result
    
    result = tempMsgBox("An error occurred. Retry or Ignore?", _
                       vbExclamation + vbAbortRetryIgnore + vbDefaultButton4, _
                       msgTitle, _
                       msTime)
    Debug.Print "vbDefaultButton4"
    printUserChoice result
    
    Debug.Print String(50, "-")
End Sub

Public Sub Test_msgBtnRemapping()
    Debug.Print "Testing two-button combinations..."
    
    ' Test Yes/No with different default buttons
    Debug.Print "Testing Yes/No"
    Dim result As VbMsgBoxResult
    result = tempMsgBox("Test YesNo DB3", vbYesNo + vbDefaultButton3, "Test", 5000)
    printUserChoice result
    result = tempMsgBox("Test YesNo DB4", vbYesNo + vbDefaultButton4, "Test", 5000)
    printUserChoice result
    
    Debug.Print "Testing three-button combinations..."
    
    ' Test AbortRetryIgnore with different default buttons
    Debug.Print "Testing AbortRetryIgnore"
    result = tempMsgBox("Test ARI DB4", vbAbortRetryIgnore + vbDefaultButton4, "Test", 5000)
    printUserChoice result
End Sub

 

[jjafferr]

شكرا على هذه الافكار الجيدة 🙂

مرة من المرات وانا اتحاور مع الذكاء الصناعي AI لكتابة كود لشيء معين ،

قلت له ، لماذا هذا الكود الطويل ، رجاء اختصاره 🙂

 

ايش بطول الكود في هذا الموضوع 🙂

 

 

 

[Ahmos]

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

في بعض الاحيان لا تكتفي بكود يقوم بعمل المطلوب فقط
علي سبيل المثال دائماً كنت أتعامل مع الـ Windows Registry من خلال الـ WScript.Shell فالأكود أسهل وأصغر
ولكنه لا يعطيك تحكم كامل(مثال لا يمكن عمل قائمة بكل المفاتيح الفرعية تحت مفتاح رئيسي من خلال WScript) ، والتعامل من خلال الـ WIN API أسرع وأشمل
ومررت علي هذا الموضوع القديم http://www.cpearson.com/Excel/Registry.htm
وهنا يعطيك تحكم كامل بالريجيستري

أيضاً :
إذا كان الجهاز ضمن نطاق شركة فإحتمالية أن يقوم الـ IT بتعطيل WScript علي أجهزة المستخدمين للأمن أعلي

وعندما كنت أبحث عن إجابات بشكل عام كنت أجدها في كثير من الأحيان وسط أكواد او أفكار

لذلك قررت نشر الكود بتافصيله وبتجاربة لعل أحداً ينتفع بأي منها

وقد أستفدت كثيراً من الأخوة والاساتذة الكرام في هذا المنتدي ( ما عليكم زود )
أسئال الله لكم التوفيق وأن يرزقكم جميعاً الصدق والإخلاص
وأن لا يعرف الشيطان طريقاً إلي أعمالكم ولا إلي قلوبكم
بارك الله فيكم

 

[jjafferr]

المعذرة اخوي @Ahmos ، الظاهر سياق كلماتي اعطت مفهوم غير مقصود ، فانا اعتذر منك.

ما كان كلامي عن الفكرة ، وانما عن طول وطريقة اكواد AI .

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

 

واتطلع لمزيد من الافكار اللي تساعد المبرمج.

 

جعفر

[Ahmos]

أخي الفاضل @jjafferr
أسعد الله صباحك بكل خير

الكود بالاساس لم يكن بالـ AI ولكني بدأت مؤخراً أعطي اكواد أعمل بها للـ Ai 
لإعادة التنسيق وأسئل إذا كان هناك حل افضل او ان كان يستطيع عمل تعديلات وإضافات أخرى

وهناك حالة استوقفتني مثال :
لو كان أختيارك للأزرار هو vbYesNo
وأخترت الزر الافتراضي 3 وجدت انه يعود بنفس قيمة vbYes 
و ان كان الزر الافتراضي 4 فيعود بقيمة vbNo
ولكن عند المشاهدة وقت ظهور الرسالة في الحالتين تجد الاختيار الإفتراضي علي vbYes 

وإن كان اختيار لثلاث ازرار كـ vbYesNoCancel و vbAbortRetryIgnore
إذا أخترت الزر الافتراضي الـ4 تجد انه يعود دائماً بقيمة الزر الأوسط
لذلك أردت عمل إعادة توجية للأزرار في حال تم اختيار الزر الافتراضي خطأً أثناء البرمجة
يعود بالقيم الصحيحة أثناء المشاهدة والإجابة

والحل الذي اعتمدت عليه لم يكن بجودة الحل الذي قدمة الي الـ AI (ولكن ليس من أول محاولة)

أشكر لك حرصك وتوضيحك
طيب الله أوقاتك وحفظك وبارك فيك
وإن كان هناك اي تعديل فلا أمانع العمل عليه وإن تفضلت به فهو من طيبك

 

[jjafferr]

في الواقع ما تعمقت كثيرا في مثالي ، وشكرا على الملاحظة 🙂

 

ومثل ما قلت ، دائما نتطلع لأفكار جديدة 🙂