Ahmos قام بنشر الأحد at 08:07 مشاركة قام بنشر الأحد at 08:07 (معدل) السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم رابط الأصدار الأول : [ رابط وظيفة ضرورية (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 بالتوفيق تم تعديل الأحد at 10:17 بواسطه Ahmos معملتش حسـاب vbQuestion :) 1 رابط هذا التعليق شارك More sharing options...
عمر ضاحى قام بنشر الأحد at 11:37 مشاركة قام بنشر الأحد at 11:37 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 بالتوفيق اشكرك على مشاركة هذا الكود الجميل 🌹 1 رابط هذا التعليق شارك More sharing options...
Foksh قام بنشر الأحد at 12:54 مشاركة قام بنشر الأحد at 12:54 ما شاء الله ، عمل جميل ويستحق التمعن والتمحص في الأكواد ولو كملت الموضوع بإنك ترفق ملف حتى يرى بعض الأخوة كيفية العمل والاستدعاء .... رابط هذا التعليق شارك More sharing options...
Ahmos قام بنشر منذ 4 ساعات الكاتب مشاركة قام بنشر منذ 4 ساعات السلام عليكم ورحمة الله وبركاته الأخوة الكرام / أسعد الله أوقاتكم أخي الكريم @عمر ضاحى شكراً لك أخي الفاضل @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 2 رابط هذا التعليق شارك More sharing options...
Ahmos قام بنشر منذ 1 ساعه الكاتب مشاركة قام بنشر منذ 1 ساعه الإضافة اللي بفكر فيها حالياً أنسب وأسهل طريقة أضيف بيها إجراء يعمل عند أختيار المستخدم للأزرار حتي الان الوظيفة 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" ] } } } } أفيدونا أفادكم الله رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان