[ إصدار جديد ] - [ فكرة بسيطة لطباعة أو إظهار رسائل بنتائج الأكواد مع إمكانية التفعيل والتعطيل ]

[Ahmos]

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

رابط الأصدار الأول : [

رابط وظيفة ضرورية (tempMsgBox) لعمل هذا الإصدار : [

الجديد في هذا الأصدار :
1- تعديل إسم الوظيفة إلي MsgLog لسهولة الاستخدام
2- إضافة خاصية الرسائل المؤقتة
3- إضافة خاصية اللغة العربية
4- إضافة تحكم لعنوان الرسالة

الهدف الأساسي هو :
أثناء البرمجة تريد أختبار الخطوات داخل الاكواد والنتائج في الـ Immediate Window
وبعد الإنتهاء تريد إيقاف هذه الأوامر التي تطبع داخل الـ Immediate Window وتفعيل الرسائل العادية أو المؤقتة
وهنا تأتي دور الوظيفة فيمكنك عمل ثابت عام مثل

Public Const Debugging_Mode_ON  As Boolean = True
Public Const MsgBox_Mode_ON     As Boolean = False

وتستخدم هكذا

MsgLog "هنا نص الرسـالة ؟", _
        llCritical, _
        Debugging_Mode_ON, _
        MsgBox_Mode_ON, _
        "هنـا عنوان الرسالة", _
        True, _
        mbYesNo, _
        db2Second, _
        SecToMs(6)

الشرح :

    MsgLog "هنا نص الرسـالة ؟", _
        llCritical, _                   ' هنا لأختيار مستوي وأيقونة الرسالة
        Debugging_Mode_ON , _           ' هنا تم ربطها بالثابت العام لطباعة النتائج
        MsgBox_Mode_ON , _              ' هنا تم ربطها بالثابت العام لإظهار الرسائل
        "هنـا عنوان الرسالة", _
        True, _                         ' هنا تضع TRUE للغة العربية النص إلي اليمين
        mbYesNo , _                     ' هنا إختيار الأزرار
        db2Second , _                   ' هنا إختيار الزر الأفتراضي
        SecToMs (6)                     ' هنا لتحديد الوقت المؤقت للرسالة في حال لم يستخدم هذا الخيار ستصبح رسالة عادية
    

يتم إضافة الوقت المختار للرسائل المؤقتة بشكل إفترضي لعنوان الرسالة

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

Option Compare Database
Option Explicit

'----------------------------------------------------------------------------------------------------------
' Module    : AWS_LOG_Message
' Author    : Original: Ahmos - The Last Egyptian King
'             Enhanced: Ahmos - The Last Egyptian King
' Email     : Phoronex@yahoo.com
' Purpose   : Provide flexible logging functionality with various log levels and options
' Copyright : © 2024 Ahmos. Released under Attribution 4.0 International
'             (CC BY 4.0) - https://creativecommons.org/licenses/by/4.0/
'
' Usage:
' ~~~~~~
' Basic Examples
' MsgLog "Basic message", llInfo                                            ' Simple info log
' MsgLog "Continue?", llWarning, , True, "Warning", False, mbYesNo          ' Warning with Yes/No prompt
' MsgLog "Debug log only", llInfo, True                                     ' Log only to Debug window
' MsgLog "Retry?", llError, , True, "Error", False, mbRetryCancel, _
'        db2Second, SecToMs(5)                                              ' Retry/Cancel with timeout of 5 seconds
' MsgLog "رسالة باللغة العربية", llWarning, , True, "تحذير", True, mbOKOnly ' Arabic Right-to-Left Message Box with Warning
' MsgLog "Proceed?", llInfo, , True, "Custom Title", False, _
'        mbYesNoCancel, db1First                                            ' Custom title with Yes/No/Cancel
' MsgLog "Full settings example", llCritical, True, True, _
'        "Critical Alert", False, mbYesNo, db3Third, 4000                   ' Critical level, Debug, Yes/No with 4-second timeout
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ---------------------------------------------------------------------------------------------------------
' 1         2024-10-30              Initial version
' 2         2024-11-01              Added timeout message box functionality
' 3         2024-11-01              Added button configuration enums:
'                                   - Message box buttons enum
'                                   - Default button position enum
'                                   - Enhanced button handling
' 4         2024-11-02              Added comprehensive test cases to verify MsgLog functionality
'                                   - Created TestMsgLog subroutine with varied scenarios
'                                   - Documented usage examples for common and complex cases
' 5         2024-11-02              Expanded MsgLog with the following features:
'                                   - Debug output control to toggle message logging to Debug window
'                                   - RTL (Right-to-Left) text support for Arabic and other RTL languages
'                                   - Custom message box titles for user-defined prompts
'                                   - Message box button configuration with detailed control over button types
'                                   - Enhanced default button selection
'                                   - Structured revision history to track feature updates and usage improvements
' ---------------------------------------------------------------------------------------------------------

' Functions:
' ~~~~~~~~~~
' MsgLog            : Flexible logging with debug and message box options
' FormatLogMessage  : Helper function to format log messages consistently
' SecToMs           : Convert seconds to milliseconds
' MsToSec           : Convert milliseconds to seconds
'
' Notes:
' ~~~~~~
' - Supports all standard message box button combinations via enums
' - Default button position can be specified
' - Timeout message boxes with automatic close
' - Time conversion utilities for easier timeout specification
'----------------------------------------------------------------------------------------------------------
'        **-----**_______________{]___________________________________________________________
'        {&&&&&&&#%%&#%&%&%&%&%#%&|]__________________________The Last Egyptian King___________\
'                                  {]
'----------------------------------------------------------------------------------------------------------

' Enums
Public Enum LogLevel
    llInfo = 0
    llWarning = 1
    llError = 2
    llCritical = 3
	llQuestion = 4
End Enum

' Message Box Buttons Enum
Public Enum MsgBoxButtons
    mbOKOnly = vbOKOnly                             ' OK button only
    mbOKCancel = vbOKCancel                         ' OK and Cancel buttons
    mbYesNo = vbYesNo                               ' Yes and No buttons
    mbYesNoCancel = vbYesNoCancel                   ' Yes, No, and Cancel buttons
    mbRetryCancel = vbRetryCancel                   ' Retry and Cancel buttons
    mbAbortRetryIgnore = vbAbortRetryIgnore         ' Abort, Retry, and Ignore buttons
End Enum

' Default Button Position Enum
Public Enum defaultButton
    db1First = vbDefaultButton1                     ' First button is default
    db2Second = vbDefaultButton2                    ' Second button is default
    db3Third = vbDefaultButton3                     ' Third button is default
    db4Fourth = vbDefaultButton4                    ' Fourth button is default
End Enum


' Constants
Private Const MIN_TIMEOUT       As Long = 1000      ' 1 second
Private Const MAX_TIMEOUT       As Long = 300000    ' 5 minutes
Private Const DEFAULT_TIMEOUT   As Long = 5000      ' 5 seconds


'/// Function: SecondsToMs
'/// Converts seconds to milliseconds
Public Function SecToMs(ByVal seconds As Double) As Long
    SecToMs = CLng(seconds * 1000)
End Function

'/// Function: MsToSeconds
'/// Converts milliseconds to seconds
Public Function MsToSec(ByVal milliseconds As Long) As Double
    MsToSec = milliseconds / 1000
End Function

' Helper function to format log messages
Private Function FormatLogMessage(ByVal message As String, ByVal level As LogLevel) As String
    Dim prefix As String
    
    Select Case level
        Case llInfo
            prefix = "INFO     "
        Case llWarning
            prefix = "WARNING  "
        Case llError
            prefix = "ERROR    "
        Case llCritical
            prefix = "CRITICAL "
		Case llQuestion
            prefix = "Question "
    End Select
    
    FormatLogMessage = "[" & prefix & "] " & ": " & message
End Function

' Helper function to format log messages to MsgBox
Function FormatMsgBox(ByVal sMessage As String) As String
    
    Dim colonPos    As Long
    Dim bracketPos  As Long
    

    bracketPos = InStr(sMessage, "]")
    
    If bracketPos > 0 Then
        ' Find the first colon after the closing square bracket
        colonPos = InStr(bracketPos, sMessage, ":")
        
        If colonPos > 0 Then
            ' Replace only the first colon with a colon followed by a line break
            FormatMsgBox = Left(sMessage, colonPos) & vbCrLf & Mid(sMessage, colonPos + 1)
        Else
            ' If no colon is found, return the original string
            FormatMsgBox = sMessage
        End If
    Else
        ' If no closing bracket is found, return the original string
        FormatMsgBox = sMessage
    End If
End Function

'/// Sub: MsgLog
'/// Logs a message with various options for display and handling
'/// @param message - The message to be logged
'/// @param level - (Optional) The log level (default: llInfo)
'/// @param useDebug - (Optional) Whether to use debug output (default: False)
'/// @param showMsgBox - (Optional) Whether to show a message box (default: False)
'/// @param msgTitle - (Optional) The title of the message box (default: "")
'/// @param arabicRTL - (Optional) Whether to use right-to-left layout for Arabic text (default: False)
'/// @param buttons - (Optional) The buttons to display in the message box (default: mbOKOnly)
'/// @param defaultButton - (Optional) The default button in the message box (default: db1First)
'/// @param timeoutMs - (Optional) Timeout in milliseconds for the message box. Ex: SecToMs(5) or 5000

Public Sub MsgLog(ByVal message As String, _
                 Optional ByVal level As LogLevel = llInfo, _
                 Optional ByVal useDebug As Boolean = False, _
                 Optional ByVal showMsgBox As Boolean = False, _
                 Optional ByVal msgTitle As String = "", _
                 Optional ByVal arabicRTL As Boolean = False, _
                 Optional ByVal buttons As MsgBoxButtons = mbOKOnly, _
                 Optional ByVal defaultButton As defaultButton = db1First, _
                 Optional ByVal timeoutMs As Variant)
    
    Dim msgBoxStyle     As VbMsgBoxStyle
    Dim msgBoxTitle     As String
    Dim fullMessage     As String
    Dim actualTimeout   As Long
    Dim result          As VbMsgBoxResult
    Dim mTitle          As String
    
    ' Format the message
    fullMessage = FormatLogMessage(message, level)
    
    ' Set message box properties based on log level
    Select Case level
        Case llInfo
            msgBoxStyle = vbInformation
            If arabicRTL = False Then
                msgBoxTitle = "Information"
            Else
                msgBoxTitle = ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629)
            End If
        Case llWarning
            msgBoxStyle = vbExclamation
            If arabicRTL = False Then
                msgBoxTitle = "Warning"
            Else
                msgBoxTitle = ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631)
            End If
        Case llError
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623)
            End If
        Case llCritical
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Critical Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H62E) & ChrW(&H637) & ChrW(&H64A) & ChrW(&H631)
            End If
        
        Case llQuestion
            msgBoxStyle = vbQuestion
            If arabicRTL = False Then
                msgBoxTitle = "Question"
            Else
                msgBoxTitle = ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644)
            End If
    End Select
    
    If msgTitle = "" Then
    
    Else
        msgBoxTitle = msgTitle
    End If
    
    ' Combine style with buttons and default button
    If arabicRTL = False Then
        msgBoxStyle = msgBoxStyle + buttons + vbMsgBoxSetForeground + defaultButton
    Else
      msgBoxStyle = msgBoxStyle + vbMsgBoxRight + vbMsgBoxRtlReading + buttons + vbMsgBoxSetForeground + defaultButton
    End If
    ' Output to Debug if requested
    If useDebug Then
        ' Use This format upon your needs
'        Debug.Print format(Now, "yyyy-mm-dd hh:nn:ss AM/PM") & " " & Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
        Debug.Print Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
    End If
    
    ' Show message box if requested
    If showMsgBox Then
        fullMessage = FormatMsgBox(fullMessage)
        
        If arabicRTL = False Then
            
        Else
            fullMessage = Replace(fullMessage, "INFO     ", ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "WARNING  ", ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "ERROR    ", ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "CRITICAL ", ChrW(&H647) & ChrW(&H627) & ChrW(&H645) & ChrW(&H20) & ChrW(&H62C) & ChrW(&H62F) & ChrW(&H627) & ChrW(&H64B) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "Question ", ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
        End If
        
        If IsMissing(timeoutMs) Or VarType(timeoutMs) = vbString Then
            ' Use standard MsgBox if no timeout specified
            MsgBox fullMessage, msgBoxStyle, msgBoxTitle
        Else
            If IsNumeric(timeoutMs) Then
                actualTimeout = CLng(timeoutMs)
            Else
                actualTimeout = DEFAULT_TIMEOUT
            End If

            If actualTimeout < MIN_TIMEOUT Then actualTimeout = MIN_TIMEOUT
            If actualTimeout > MAX_TIMEOUT Then actualTimeout = MAX_TIMEOUT
            
            ' Use tempMsgBox with timeout
            If arabicRTL = False Then
                mTitle = " - " & Round(MsToSec(actualTimeout), 1) & " Sec Time-Out MSG"
            Else
                mTitle = " - " & _
                    ChrW(&H20) & ChrW(&H631) & ChrW(&H633) & ChrW(&H627) & ChrW(&H644) & ChrW(&H629) & ChrW(&H20) & ChrW(&H645) & ChrW(&H624) & ChrW(&H642) & ChrW(&H62A) & ChrW(&H629) & ChrW(&H20) & ChrW(&H644) & ChrW(&H645) & ChrW(&H62F) & ChrW(&H629) & ChrW(&H20) & _
                    Round(MsToSec(actualTimeout), 1) & _
                    ChrW(&H20) & ChrW(&H62B) & ChrW(&H648) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A)
            End If
            result = tempMsgBox(fullMessage, msgBoxStyle, msgBoxTitle & mTitle, actualTimeout)
            
'            printUserChoice result
        End If
    End If
End Sub



' Test subroutine to run different cases for MsgLog function
Public Sub TestMsgLog()

    ' Test Case 1: Basic Info Log to Debug
    MsgLog "Basic info message logged to debug window.", llInfo, True
    
    ' Test Case 2: Error Log with Message Box Display
    MsgLog "Error message with message box display.", llError, False, True, "Error Title", False, mbOKOnly
    
    ' Test Case 3: Warning Log, Arabic Right-to-Left Message Box
    MsgLog "تنبيه: رسالة في اتجاه اليمين", llWarning, False, True, "تحذير", True, mbOKOnly
    
    ' Test Case 4: Info Log with Custom Title, Yes/No Message Box, Timeout of 3 seconds
    MsgLog "Confirmation needed: Proceed with operation?", llInfo, False, True, "Confirm Operation", False, mbYesNo, db1First, 3000
    
    ' Test Case 5: Critical Log Level, Message Box with OK/Cancel, No Debug Output
    MsgLog "Critical issue, user action required.", llCritical, False, True, "Critical Alert", False, mbOKCancel, db2Second
    
    ' Test Case 6: Debug-only Info Log, No Message Box Display
    MsgLog "Debug info only, no user prompt.", llInfo, True, False
    
    ' Test Case 7: Error Log, Custom Title and Buttons, Timeout, with Debug Output
    MsgLog "Error with custom settings and debug output.", llError, True, True, "Custom Error", False, mbRetryCancel, db1First, 5000
    
    ' Test Case 8: Arabic RTL Warning with Timeout, Debug Off, Message Box with Yes/No
    MsgLog "تحذير مع مهلة وتأكيد بنعم أو لا.", llWarning, False, True, "تأكيد", True, mbYesNo, db2Second, 2000
    
    ' Test Case 9: Information Level with Title, OK Only, Arabic RTL Disabled
    MsgLog "General information message.", llInfo, False, True, "Info", False, mbOKOnly
    
    ' Test Case 10: Critical with Arabic RTL and Debug Enabled
    MsgLog "حالة حرجة مع اتجاه اليمين وتصحيح ممكّن.", llCritical, True, True, "حالة حرجة", True, mbOKCancel, db1First
    
    ' Test Case 11: Minimal Settings, Only Debug
    MsgLog "Minimal debug message.", , True

    ' Test Case 12: Maximal Settings, Full Debug and Message Box with Timeout
    MsgLog "Full settings message for detailed log.", llInfo, True, True, "Full Settings Test", False, mbYesNoCancel, db3Third, SecToMs(4)


End Sub

بالتوفيق

تم تعديل نوفمبر 3 بواسطه Ahmos
معملتش حسـاب vbQuestion :)

[عمر ضاحى]

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

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

رابط الأصدار الأول : [

رابط وظيفة ضرورية (tempMsgBox) لعمل هذا الإصدار : [

الجديد في هذا الأصدار :
1- تعديل إسم الوظيفة إلي MsgLog لسهولة الاستخدام
2- إضافة خاصية الرسائل المؤقتة
3- إضافة خاصية اللغة العربية
4- إضافة تحكم لعنوان الرسالة

الهدف الأساسي هو :
أثناء البرمجة تريد أختبار الخطوات داخل الاكواد والنتائج في الـ Immediate Window
وبعد الإنتهاء تريد إيقاف هذه الأوامر التي تطبع داخل الـ Immediate Window وتفعيل الرسائل العادية أو المؤقتة
وهنا تأتي دور الوظيفة فيمكنك عمل ثابت عام مثل

Public Const Debugging_Mode_ON  As Boolean = True
Public Const MsgBox_Mode_ON     As Boolean = False

وتستخدم هكذا

MsgLog "هنا نص الرسـالة ؟", _
        llCritical, _
        Debugging_Mode_ON, _
        MsgBox_Mode_ON, _
        "هنـا عنوان الرسالة", _
        True, _
        mbYesNo, _
        db2Second, _
        SecToMs(6)

الشرح :

    MsgLog "هنا نص الرسـالة ؟", _
        llCritical, _                   ' هنا لأختيار مستوي وأيقونة الرسالة
        Debugging_Mode_ON , _           ' هنا تم ربطها بالثابت العام لطباعة النتائج
        MsgBox_Mode_ON , _              ' هنا تم ربطها بالثابت العام لإظهار الرسائل
        "هنـا عنوان الرسالة", _
        True, _                         ' هنا تضع TRUE للغة العربية النص إلي اليمين
        mbYesNo , _                     ' هنا إختيار الأزرار
        db2Second , _                   ' هنا إختيار الزر الأفتراضي
        SecToMs (6)                     ' هنا لتحديد الوقت المؤقت للرسالة في حال لم يستخدم هذا الخيار ستصبح رسالة عادية
    

يتم إضافة الوقت المختار للرسائل المؤقتة بشكل إفترضي لعنوان الرسالة

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

Option Compare Database
Option Explicit

'----------------------------------------------------------------------------------------------------------
' Module    : AWS_LOG_Message
' Author    : Original: Ahmos - The Last Egyptian King
'             Enhanced: Ahmos - The Last Egyptian King
' Email     : Phoronex@yahoo.com
' Purpose   : Provide flexible logging functionality with various log levels and options
' Copyright : © 2024 Ahmos. Released under Attribution 4.0 International
'             (CC BY 4.0) - https://creativecommons.org/licenses/by/4.0/
'
' Usage:
' ~~~~~~
' Basic Examples
' MsgLog "Basic message", llInfo                                            ' Simple info log
' MsgLog "Continue?", llWarning, , True, "Warning", False, mbYesNo          ' Warning with Yes/No prompt
' MsgLog "Debug log only", llInfo, True                                     ' Log only to Debug window
' MsgLog "Retry?", llError, , True, "Error", False, mbRetryCancel, _
'        db2Second, SecToMs(5)                                              ' Retry/Cancel with timeout of 5 seconds
' MsgLog "رسالة باللغة العربية", llWarning, , True, "تحذير", True, mbOKOnly ' Arabic Right-to-Left Message Box with Warning
' MsgLog "Proceed?", llInfo, , True, "Custom Title", False, _
'        mbYesNoCancel, db1First                                            ' Custom title with Yes/No/Cancel
' MsgLog "Full settings example", llCritical, True, True, _
'        "Critical Alert", False, mbYesNo, db3Third, 4000                   ' Critical level, Debug, Yes/No with 4-second timeout
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' ---------------------------------------------------------------------------------------------------------
' 1         2024-10-30              Initial version
' 2         2024-11-01              Added timeout message box functionality
' 3         2024-11-01              Added button configuration enums:
'                                   - Message box buttons enum
'                                   - Default button position enum
'                                   - Enhanced button handling
' 4         2024-11-02              Added comprehensive test cases to verify MsgLog functionality
'                                   - Created TestMsgLog subroutine with varied scenarios
'                                   - Documented usage examples for common and complex cases
' 5         2024-11-02              Expanded MsgLog with the following features:
'                                   - Debug output control to toggle message logging to Debug window
'                                   - RTL (Right-to-Left) text support for Arabic and other RTL languages
'                                   - Custom message box titles for user-defined prompts
'                                   - Message box button configuration with detailed control over button types
'                                   - Enhanced default button selection
'                                   - Structured revision history to track feature updates and usage improvements
' ---------------------------------------------------------------------------------------------------------

' Functions:
' ~~~~~~~~~~
' MsgLog            : Flexible logging with debug and message box options
' FormatLogMessage  : Helper function to format log messages consistently
' SecToMs           : Convert seconds to milliseconds
' MsToSec           : Convert milliseconds to seconds
'
' Notes:
' ~~~~~~
' - Supports all standard message box button combinations via enums
' - Default button position can be specified
' - Timeout message boxes with automatic close
' - Time conversion utilities for easier timeout specification
'----------------------------------------------------------------------------------------------------------
'        **-----**_______________{]___________________________________________________________
'        {&&&&&&&#%%&#%&%&%&%&%#%&|]__________________________The Last Egyptian King___________\
'                                  {]
'----------------------------------------------------------------------------------------------------------

' Enums
Public Enum LogLevel
    llInfo = 0
    llWarning = 1
    llError = 2
    llCritical = 3
	llQuestion = 4
End Enum

' Message Box Buttons Enum
Public Enum MsgBoxButtons
    mbOKOnly = vbOKOnly                             ' OK button only
    mbOKCancel = vbOKCancel                         ' OK and Cancel buttons
    mbYesNo = vbYesNo                               ' Yes and No buttons
    mbYesNoCancel = vbYesNoCancel                   ' Yes, No, and Cancel buttons
    mbRetryCancel = vbRetryCancel                   ' Retry and Cancel buttons
    mbAbortRetryIgnore = vbAbortRetryIgnore         ' Abort, Retry, and Ignore buttons
End Enum

' Default Button Position Enum
Public Enum defaultButton
    db1First = vbDefaultButton1                     ' First button is default
    db2Second = vbDefaultButton2                    ' Second button is default
    db3Third = vbDefaultButton3                     ' Third button is default
    db4Fourth = vbDefaultButton4                    ' Fourth button is default
End Enum


' Constants
Private Const MIN_TIMEOUT       As Long = 1000      ' 1 second
Private Const MAX_TIMEOUT       As Long = 300000    ' 5 minutes
Private Const DEFAULT_TIMEOUT   As Long = 5000      ' 5 seconds


'/// Function: SecondsToMs
'/// Converts seconds to milliseconds
Public Function SecToMs(ByVal seconds As Double) As Long
    SecToMs = CLng(seconds * 1000)
End Function

'/// Function: MsToSeconds
'/// Converts milliseconds to seconds
Public Function MsToSec(ByVal milliseconds As Long) As Double
    MsToSec = milliseconds / 1000
End Function

' Helper function to format log messages
Private Function FormatLogMessage(ByVal message As String, ByVal level As LogLevel) As String
    Dim prefix As String
    
    Select Case level
        Case llInfo
            prefix = "INFO     "
        Case llWarning
            prefix = "WARNING  "
        Case llError
            prefix = "ERROR    "
        Case llCritical
            prefix = "CRITICAL "
		Case llQuestion
            prefix = "Question "
    End Select
    
    FormatLogMessage = "[" & prefix & "] " & ": " & message
End Function

' Helper function to format log messages to MsgBox
Function FormatMsgBox(ByVal sMessage As String) As String
    
    Dim colonPos    As Long
    Dim bracketPos  As Long
    

    bracketPos = InStr(sMessage, "]")
    
    If bracketPos > 0 Then
        ' Find the first colon after the closing square bracket
        colonPos = InStr(bracketPos, sMessage, ":")
        
        If colonPos > 0 Then
            ' Replace only the first colon with a colon followed by a line break
            FormatMsgBox = Left(sMessage, colonPos) & vbCrLf & Mid(sMessage, colonPos + 1)
        Else
            ' If no colon is found, return the original string
            FormatMsgBox = sMessage
        End If
    Else
        ' If no closing bracket is found, return the original string
        FormatMsgBox = sMessage
    End If
End Function

'/// Sub: MsgLog
'/// Logs a message with various options for display and handling
'/// @param message - The message to be logged
'/// @param level - (Optional) The log level (default: llInfo)
'/// @param useDebug - (Optional) Whether to use debug output (default: False)
'/// @param showMsgBox - (Optional) Whether to show a message box (default: False)
'/// @param msgTitle - (Optional) The title of the message box (default: "")
'/// @param arabicRTL - (Optional) Whether to use right-to-left layout for Arabic text (default: False)
'/// @param buttons - (Optional) The buttons to display in the message box (default: mbOKOnly)
'/// @param defaultButton - (Optional) The default button in the message box (default: db1First)
'/// @param timeoutMs - (Optional) Timeout in milliseconds for the message box. Ex: SecToMs(5) or 5000

Public Sub MsgLog(ByVal message As String, _
                 Optional ByVal level As LogLevel = llInfo, _
                 Optional ByVal useDebug As Boolean = False, _
                 Optional ByVal showMsgBox As Boolean = False, _
                 Optional ByVal msgTitle As String = "", _
                 Optional ByVal arabicRTL As Boolean = False, _
                 Optional ByVal buttons As MsgBoxButtons = mbOKOnly, _
                 Optional ByVal defaultButton As defaultButton = db1First, _
                 Optional ByVal timeoutMs As Variant)
    
    Dim msgBoxStyle     As VbMsgBoxStyle
    Dim msgBoxTitle     As String
    Dim fullMessage     As String
    Dim actualTimeout   As Long
    Dim result          As VbMsgBoxResult
    Dim mTitle          As String
    
    ' Format the message
    fullMessage = FormatLogMessage(message, level)
    
    ' Set message box properties based on log level
    Select Case level
        Case llInfo
            msgBoxStyle = vbInformation
            If arabicRTL = False Then
                msgBoxTitle = "Information"
            Else
                msgBoxTitle = ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629)
            End If
        Case llWarning
            msgBoxStyle = vbExclamation
            If arabicRTL = False Then
                msgBoxTitle = "Warning"
            Else
                msgBoxTitle = ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631)
            End If
        Case llError
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623)
            End If
        Case llCritical
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Critical Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H62E) & ChrW(&H637) & ChrW(&H64A) & ChrW(&H631)
            End If
        
        Case llQuestion
            msgBoxStyle = vbQuestion
            If arabicRTL = False Then
                msgBoxTitle = "Question"
            Else
                msgBoxTitle = ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644)
            End If
    End Select
    
    If msgTitle = "" Then
    
    Else
        msgBoxTitle = msgTitle
    End If
    
    ' Combine style with buttons and default button
    If arabicRTL = False Then
        msgBoxStyle = msgBoxStyle + buttons + vbMsgBoxSetForeground + defaultButton
    Else
      msgBoxStyle = msgBoxStyle + vbMsgBoxRight + vbMsgBoxRtlReading + buttons + vbMsgBoxSetForeground + defaultButton
    End If
    ' Output to Debug if requested
    If useDebug Then
        ' Use This format upon your needs
'        Debug.Print format(Now, "yyyy-mm-dd hh:nn:ss AM/PM") & " " & Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
        Debug.Print Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
    End If
    
    ' Show message box if requested
    If showMsgBox Then
        fullMessage = FormatMsgBox(fullMessage)
        
        If arabicRTL = False Then
            
        Else
            fullMessage = Replace(fullMessage, "INFO     ", ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "WARNING  ", ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "ERROR    ", ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "CRITICAL ", ChrW(&H647) & ChrW(&H627) & ChrW(&H645) & ChrW(&H20) & ChrW(&H62C) & ChrW(&H62F) & ChrW(&H627) & ChrW(&H64B) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "Question ", ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
        End If
        
        If IsMissing(timeoutMs) Or VarType(timeoutMs) = vbString Then
            ' Use standard MsgBox if no timeout specified
            MsgBox fullMessage, msgBoxStyle, msgBoxTitle
        Else
            If IsNumeric(timeoutMs) Then
                actualTimeout = CLng(timeoutMs)
            Else
                actualTimeout = DEFAULT_TIMEOUT
            End If

            If actualTimeout < MIN_TIMEOUT Then actualTimeout = MIN_TIMEOUT
            If actualTimeout > MAX_TIMEOUT Then actualTimeout = MAX_TIMEOUT
            
            ' Use tempMsgBox with timeout
            If arabicRTL = False Then
                mTitle = " - " & Round(MsToSec(actualTimeout), 1) & " Sec Time-Out MSG"
            Else
                mTitle = " - " & _
                    ChrW(&H20) & ChrW(&H631) & ChrW(&H633) & ChrW(&H627) & ChrW(&H644) & ChrW(&H629) & ChrW(&H20) & ChrW(&H645) & ChrW(&H624) & ChrW(&H642) & ChrW(&H62A) & ChrW(&H629) & ChrW(&H20) & ChrW(&H644) & ChrW(&H645) & ChrW(&H62F) & ChrW(&H629) & ChrW(&H20) & _
                    Round(MsToSec(actualTimeout), 1) & _
                    ChrW(&H20) & ChrW(&H62B) & ChrW(&H648) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A)
            End If
            result = tempMsgBox(fullMessage, msgBoxStyle, msgBoxTitle & mTitle, actualTimeout)
            
'            printUserChoice result
        End If
    End If
End Sub



' Test subroutine to run different cases for MsgLog function
Public Sub TestMsgLog()

    ' Test Case 1: Basic Info Log to Debug
    MsgLog "Basic info message logged to debug window.", llInfo, True
    
    ' Test Case 2: Error Log with Message Box Display
    MsgLog "Error message with message box display.", llError, False, True, "Error Title", False, mbOKOnly
    
    ' Test Case 3: Warning Log, Arabic Right-to-Left Message Box
    MsgLog "تنبيه: رسالة في اتجاه اليمين", llWarning, False, True, "تحذير", True, mbOKOnly
    
    ' Test Case 4: Info Log with Custom Title, Yes/No Message Box, Timeout of 3 seconds
    MsgLog "Confirmation needed: Proceed with operation?", llInfo, False, True, "Confirm Operation", False, mbYesNo, db1First, 3000
    
    ' Test Case 5: Critical Log Level, Message Box with OK/Cancel, No Debug Output
    MsgLog "Critical issue, user action required.", llCritical, False, True, "Critical Alert", False, mbOKCancel, db2Second
    
    ' Test Case 6: Debug-only Info Log, No Message Box Display
    MsgLog "Debug info only, no user prompt.", llInfo, True, False
    
    ' Test Case 7: Error Log, Custom Title and Buttons, Timeout, with Debug Output
    MsgLog "Error with custom settings and debug output.", llError, True, True, "Custom Error", False, mbRetryCancel, db1First, 5000
    
    ' Test Case 8: Arabic RTL Warning with Timeout, Debug Off, Message Box with Yes/No
    MsgLog "تحذير مع مهلة وتأكيد بنعم أو لا.", llWarning, False, True, "تأكيد", True, mbYesNo, db2Second, 2000
    
    ' Test Case 9: Information Level with Title, OK Only, Arabic RTL Disabled
    MsgLog "General information message.", llInfo, False, True, "Info", False, mbOKOnly
    
    ' Test Case 10: Critical with Arabic RTL and Debug Enabled
    MsgLog "حالة حرجة مع اتجاه اليمين وتصحيح ممكّن.", llCritical, True, True, "حالة حرجة", True, mbOKCancel, db1First
    
    ' Test Case 11: Minimal Settings, Only Debug
    MsgLog "Minimal debug message.", , True

    ' Test Case 12: Maximal Settings, Full Debug and Message Box with Timeout
    MsgLog "Full settings message for detailed log.", llInfo, True, True, "Full Settings Test", False, mbYesNoCancel, db3Third, SecToMs(4)


End Sub

بالتوفيق

اشكرك على مشاركة هذا الكود الجميل 🌹

[Foksh]

ما شاء الله ، عمل جميل ويستحق التمعن والتمحص في الأكواد 

ولو كملت الموضوع بإنك ترفق ملف حتى يرى بعض الأخوة كيفية العمل والاستدعاء .... 

 

 

[Ahmos]

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

الأخوة الكرام / أسعد الله أوقاتكم

أخي الكريم @عمر ضاحى شكراً لك

أخي الفاضل @Foksh تفضل أخي الكريم المثال المرفق

مصدر وظائف التحقق من الموقع من هنا :
1- https://www.devhut.net/using-regex-to-validate-a-url/

2- https://www.devhut.net/vba-validate-if-a-url-exists/

تم التعديل فقط لتناسب الفكرة

تم إضافة الكود التالي للوظيفة الرئيسية MsgLog وهو ليس ضروري ويمكن استبدالة بمعرف ثابت (ليعمل داخل الاكسل)

TempVars.Remove "tempLog"
    TempVars!tempLog = Replace(fullMessage, vbCrLf, vbCrLf & String(18, " "))

أمثلة للأختبار

? MSXML_URLExist("https://httpstat.us/408")
? MSXML_URLExist("https://www.yahoo.com/" & String(50000, "a"))
? MSXML_URLExist("https://www.google.com/" & String(50000, "a"))
? MSXML_URLExist("https://httpstat.us/504")
? MSXML_URLExist("https://httpstat.us/200?sleep=10000")
? MSXML_URLExist("https://www.google.com")
? MSXML_URLExist("https://httpstat.us/503")
? MSXML_URLExist("https://httpstat.us/414")

إذا كنت تختبر الأمر في وضع المطور علي شاشة تحرير الأكود فعليك تعديل الخيارت التالية إلي

Public Const Debugging_Mode_ON  As Boolean = True
Public Const MsgBox_Mode_ON     As Boolean = False

أرجو لكم التوفيق والسداد

MsgLog_UrlChecker.accdb

[Ahmos]

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

حتي الان الوظيفة MsgLog لا تتعامل مع إختيار المستخدمين للأزرار
الإختيارات اللي بفكر فيها بصوت عالي معاكم هي:
1- المطلوب إضافة علي الأكثر 3 إجراءات لثلاث أزرار
2- هل يمكن عمل كود لإنشاء لكتابة وظيفة داخل موديل جديد ثم تطبيقها ثم حذفها
    نعم ولكن ليس بعدما يتم عمل Compile للأكواد في صيغة الـ VBE لذلك أستبعدت الفكرة
3- هل يتم تعريف 3 بارمات ويتم إستخدامهم علي الترتيب
4- هل يتم إضافة بارم واحد عبارة عن Array
5- هل يتم إضافة بارم واحد عبارة عن Json String
    ما يميز هذا الإجراء وهو ما اميل إليه ان الـ Json يحمل Keys and Values
    وبالتالي يمكن التعامل مع الأمر بتفاصيل أكبر والتحقق من وجود Keys مثلاً
 

{
  "awsData": {
    "vbYesNo": {
      "vbYes": {
        "Debug": "Test To Debug",
        "Function": "Functions To Call",
        "Actions": [
          "Call Public Sub 1",
          "Call Public Sub 2"
        ]
      },
      "vbNo": {
        "Debug": "Test To Debug",
        "Function": "Functions To Call",
        "Actions": [
          "Call Public Sub 1",
          "Call Public Sub 2"
        ]
      }
    }
  }
}

أفيدونا أفادكم الله

[Ahmos]

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

الحل ببساطة :- 
 

'/// Function: MsgLog2
'/// Logs a message with various options for display and handling
'/// @param message - The message to be logged
'/// @param level - (Optional) The log level (default: llInfo)
'/// @param useDebug - (Optional) Whether to use debug output (default: False)
'/// @param showMsgBox - (Optional) Whether to show a message box (default: False)
'/// @param msgTitle - (Optional) The title of the message box (default: "")
'/// @param arabicRTL - (Optional) Whether to use right-to-left layout for Arabic text (default: False)
'/// @param buttons - (Optional) The buttons to display in the message box (default: mbOKOnly)
'/// @param defaultButton - (Optional) The default button in the message box (default: db1First)
'/// @param timeoutMs - (Optional) Timeout in milliseconds for the message box. Ex: SecToMs(5) or 5000


Public Function MsgLog2(ByVal message As String, _
                 Optional ByVal level As LogLevel = llInfo, _
                 Optional ByVal useDebug As Boolean = False, _
                 Optional ByVal showMsgBox As Boolean = False, _
                 Optional ByVal msgTitle As String = "", _
                 Optional ByVal arabicRTL As Boolean = False, _
                 Optional ByVal buttons As MsgBoxButtons = mbOKOnly, _
                 Optional ByVal defaultButton As defaultButton = db1First, _
                 Optional ByVal timeoutMs As Variant) As VbMsgBoxResult
    
    Dim msgBoxStyle     As VbMsgBoxStyle
    Dim msgBoxTitle     As String
    Dim fullMessage     As String
    Dim actualTimeout   As Long
    Dim mResult         As VbMsgBoxResult
    Dim tResult         As VbMsgBoxResult
    Dim mTitle          As String
    
    MsgLog2 = vbOK

    ' Format the message
    fullMessage = FormatLogMessage(message, level)
    
    ' Set message box properties based on log level
    Select Case level
        Case llInfo
            msgBoxStyle = vbInformation
            If arabicRTL = False Then
                msgBoxTitle = "Information"
            Else
                msgBoxTitle = ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629)
            End If
        Case llWarning
            msgBoxStyle = vbExclamation
            If arabicRTL = False Then
                msgBoxTitle = "Warning"
            Else
                msgBoxTitle = ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631)
            End If
        Case llError
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623)
            End If
        Case llCritical
            msgBoxStyle = vbCritical
            If arabicRTL = False Then
                msgBoxTitle = "Critical Error"
            Else
                msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H62E) & ChrW(&H637) & ChrW(&H64A) & ChrW(&H631)
            End If
        
        Case llQuestion
            msgBoxStyle = vbQuestion
            If arabicRTL = False Then
                msgBoxTitle = "Question"
            Else
                msgBoxTitle = ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644)
            End If
    End Select
    
    If msgTitle = "" Then
    
    Else
        msgBoxTitle = msgTitle
    End If
    
    ' Combine style with buttons and default button
    If arabicRTL = False Then
        msgBoxStyle = msgBoxStyle + buttons + vbMsgBoxSetForeground + defaultButton
    Else
      msgBoxStyle = msgBoxStyle + vbMsgBoxRight + vbMsgBoxRtlReading + buttons + vbMsgBoxSetForeground + defaultButton
    End If
    ' Output to Debug if requested
    If useDebug Then
        ' Use This format upon your needs
'        Debug.Print format(Now, "yyyy-mm-dd hh:nn:ss AM/PM") & " " & Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
        Debug.Print Replace(fullMessage, vbCrLf, vbCrLf & String(13, " "))
    End If
    
    TempVars.Remove "tempLog"
    TempVars!tempLog = Replace(fullMessage, vbCrLf, vbCrLf & String(18, " "))
    
    ' Show message box if requested
    If showMsgBox Then
        fullMessage = FormatMsgBox(fullMessage)
        
        If arabicRTL = False Then
            
        Else
            fullMessage = Replace(fullMessage, "INFO     ", ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "WARNING  ", ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "ERROR    ", ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "CRITICAL ", ChrW(&H647) & ChrW(&H627) & ChrW(&H645) & ChrW(&H20) & ChrW(&H62C) & ChrW(&H62F) & ChrW(&H627) & ChrW(&H64B) & ChrW(&H20) & ChrW(&H20))
            fullMessage = Replace(fullMessage, "Question ", ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20))
        End If
        
        If IsMissing(timeoutMs) Or VarType(timeoutMs) = vbString Then
            ' Use standard MsgBox if no timeout specified
            MsgLog2 = MsgBox(fullMessage, msgBoxStyle, msgBoxTitle)
            
        Else
            If IsNumeric(timeoutMs) Then
                actualTimeout = CLng(timeoutMs)
            Else
                actualTimeout = DEFAULT_TIMEOUT
            End If

            If actualTimeout < MIN_TIMEOUT Then actualTimeout = MIN_TIMEOUT
            If actualTimeout > MAX_TIMEOUT Then actualTimeout = MAX_TIMEOUT
            
            ' Use tempMsgBox with timeout
            If arabicRTL = False Then
                mTitle = " - " & Round(MsToSec(actualTimeout), 1) & " Sec Time-Out MSG"
            Else
                mTitle = " - " & _
                    ChrW(&H20) & ChrW(&H631) & ChrW(&H633) & ChrW(&H627) & ChrW(&H644) & ChrW(&H629) & ChrW(&H20) & ChrW(&H645) & ChrW(&H624) & ChrW(&H642) & ChrW(&H62A) & ChrW(&H629) & ChrW(&H20) & ChrW(&H644) & ChrW(&H645) & ChrW(&H62F) & ChrW(&H629) & ChrW(&H20) & _
                    Round(MsToSec(actualTimeout), 1) & _
                    ChrW(&H20) & ChrW(&H62B) & ChrW(&H648) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A)
            End If
            MsgLog2 = tempMsgBox(fullMessage, msgBoxStyle, msgBoxTitle & mTitle, actualTimeout)
            
'            printUserChoice tResult
        End If
    End If
End Function

طريقة الإستخدام :

Dim msgResponse     As VbMsgBoxResult

msgResponse = MsgLog2("نص السؤل ؟", _
                    llQuestion, _
                    False, _
                    True, _
                    "عنوان الرسالة", _
                    True, _
                    mbYesNo, _
                    db4Fourth, _
                    SecToMs(8))
        
        If msgResponse = vbNo Then

        Else
 
        End If

 

 

MsgLog_UrlChecker_v2.accdb

تم تعديل نوفمبر 5 بواسطه Ahmos
إضافة : MsgLog2 = vbOK في بداية الكود

[Foksh]

ما شاء الله عليك أخي الكريم @Ahmos ، أبدعت في السيطرة على الفكرة وبلورتها حسب حاجتك 

 

جزاك الله خيراً ، وبارك الله فيك وزادك علماً نافعاً