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

الإضافة اللي بفكر فيها حالياً أنسب وأسهل طريقة أضيف بيها إجراء يعمل عند أختيار المستخدم للأزرار حتي الان الوظيفة 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" ] } } } } أفيدونا أفادكم الله

السلام عليكم ورحمة الله وبركاته الأخوة الكرام / أسعد الله أوقاتكم أخي الكريم @عمر ضاحى شكراً لك أخي الفاضل @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

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم رابط الأصدار الأول : [ رابط وظيفة ضرورية (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 بالتوفيق

أخي الفاضل @jjafferr أسعد الله صباحك بكل خير الكود بالاساس لم يكن بالـ AI ولكني بدأت مؤخراً أعطي اكواد أعمل بها للـ Ai لإعادة التنسيق وأسئل إذا كان هناك حل افضل او ان كان يستطيع عمل تعديلات وإضافات أخرى وهناك حالة استوقفتني مثال : لو كان أختيارك للأزرار هو vbYesNo وأخترت الزر الافتراضي 3 وجدت انه يعود بنفس قيمة vbYes و ان كان الزر الافتراضي 4 فيعود بقيمة vbNo ولكن عند المشاهدة وقت ظهور الرسالة في الحالتين تجد الاختيار الإفتراضي علي vbYes وإن كان اختيار لثلاث ازرار كـ vbYesNoCancel و vbAbortRetryIgnore إذا أخترت الزر الافتراضي الـ4 تجد انه يعود دائماً بقيمة الزر الأوسط لذلك أردت عمل إعادة توجية للأزرار في حال تم اختيار الزر الافتراضي خطأً أثناء البرمجة يعود بالقيم الصحيحة أثناء المشاهدة والإجابة والحل الذي اعتمدت عليه لم يكن بجودة الحل الذي قدمة الي الـ AI (ولكن ليس من أول محاولة) أشكر لك حرصك وتوضيحك طيب الله أوقاتك وحفظك وبارك فيك وإن كان هناك اي تعديل فلا أمانع العمل عليه وإن تفضلت به فهو من طيبك

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

السلام عليكم ورحمة الله وبركاته الأخوة الكرام تحية طيبة وبعد ،،، تقوم الفكرة علي ضبط وقت محدد للرسائل وإتاحة فرصة للمستخدم لإتخاذ القرار وعند إنتهاء المدة المحددة يتم إعتماد الزر الإفتراضي الوظيفة : 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

السلام عليكم ورحمة الله وبركاته الأخوة الكرام أسعد الله مسائكم بالخير واليمن والبركات نستخدم كثير الأمر Debug.print أو Msgbox لطباعة نتائج الأكواد والخطاء أثناء البرمجة وبعد المراجعة والإنتهاء من الكود تريد تعطيل هذه الأوامر ولذلك ولله الحمد والفضل فكرت في هذه الأداة البسيطة (الكود بالأسفل) طريقة الإستخدام : Call LogMessage "Test message", llInfo, True, True message = الرسالة او الناتج المراد طباعته level = أهمية الرسالة وقد تم تعريف 4 مستويات يمكنك الإضافة حسب إحتياجك Public Enum LogLevel llInfo = 0 llWarning = 1 llError = 2 llCritical = 3 End Enum useDebug = هل تريد طباعة النتيجة في الـ Immediate Window showMsgBox = هل تريد ظهور رسالة بالناتج وهذا يمكننا من إضافة معرف ثابت علي مستوي الوظيفة او المديول وإستخدامة للإيقاف والتفعيل Private Const Debug_Mode_ON As Boolean = True Private Const MsgBox_Mode_ON As Boolean = False كما يمكن لاحقاً إضافة خاصية لـ TempMsgBox وهي لإظهار الرسال بشكل مؤقت أعتقد ان الكود موجود بالمنتدي والنسخة التي أستخدمها بها ميزة لإختيار الزر الإفتراضي عند إنتهاء الوقت المحدد للرسالة (سأشاركها قريباً إن شاء الله) '----------------------------------------------------------------------------------------- ' 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: ' ~~~~~~ ' LogMessage "Test message", llInfo, True, True ' Log a message with debug and message box ' ' Revision History: ' Rev Date(yyyy-mm-dd) Description ' ---------------------------------------------------------------------------------------- ' 1 2024-10-30 Initial version '----------------------------------------------------------------------------------------- ' Functions: ' ~~~~~~~~~~ ' LogMessage : Flexible logging with debug and message box options ' ' ' Notes: ' ~~~~~~ ' - Logging function supports different levels (Info, Warning, Error, Critical) ' - Options for debug output and message box display '----------------------------------------------------------------------------------------- ' **-----**_______________{]___________________________________________________________ ' {&&&&&&&#%%&#%&%&%&%&%#%&|]__________________________The Last Egyptian King___________\ ' {] '----------------------------------------------------------------------------------------- Public Enum LogLevel llInfo = 0 llWarning = 1 llError = 2 llCritical = 3 End Enum Public Sub LogMessage(ByVal message As String, _ Optional ByVal level As LogLevel = llInfo, _ Optional ByVal useDebug As Boolean = False, _ Optional ByVal showMsgBox As Boolean = False) Dim prefix As String Dim msgBoxStyle As VbMsgBoxStyle Dim msgBoxTitle As String Dim fullMessage As String Select Case level Case llInfo prefix = "INFO" msgBoxStyle = vbInformation msgBoxTitle = "Information" Case llWarning prefix = "WARNING" msgBoxStyle = vbExclamation msgBoxTitle = "Warning" Case llError prefix = "ERROR" msgBoxStyle = vbCritical msgBoxTitle = "Error" Case llCritical prefix = "CRITICAL" msgBoxStyle = vbCritical msgBoxTitle = "Critical Error" End Select fullMessage = "[" & prefix & "] " & ": " & message If useDebug Then Debug.Print fullMessage End If If showMsgBox Then MsgBox fullMessage, msgBoxStyle, msgBoxTitle End If End Sub

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

أسعدك الله وبارك فيك أخي الكريم @jjafferr التعديلات : 1- تنسيق الكود 2- 3- من tex5.Value إلي Me.text5.Value وهكذا ،، 4- إضافة ErrorHandler للتعامل معا أخطاء الوظيفة SwapElementsBasics On Error GoTo ErrorHandler ErrorHandler: Debug.Print "Error in SwapElementsBasics: " & Err.Description ملحوظة : أصبحت أستخدم وسائل البحث الجديدة ( https://chatgpt.com - https://claude.ai ) في تنسيق وضبط التسمية وإضافة Error Handler فهو أسرع. بالتوفيق

السلام عليكم ورحمة الله وبركاته الخطأ هو : tocontrol معرفة كـ Integer في الوظيفة SwapelementesBasics وعند الاستخدام تم تعريف الـ currentcontrol كـ Object يوجد نسخة معدلة بالمرفق أنصحك بالاستفادة من عرض الأستاذ @jjafferr بالتوفيق Database5_New.accdb

السلام عليكم ورحمة الله وبركاته الحمد لله حمداً كثيراً طيباً مباركاً فيه الأخوة والأخوات الكرام أقدم إليكم هذه الأكواد وهي تقوم بقراءة أي جدول تقوم بتحديده وتصنع لك كود برمجي يمكنك من إعادة إنشاء الجدول مرة أخري بنفس المواصفات مصدر هام لإضافة المزيد https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/field-type-property-dao Convert_Table_To_Vba.zip

كما قال الأخوة الأفاضل قد لا نتمكن في الوقت الحالي من عمل ذلك او يمكنك البحث عن إضافة لبرنامج الاكسيس (Add-IN) قد يكون هناك ما يمكنك من ذلك وللعلم فيما يخص تحويل الـ HTML وجدت هذه الأداة (wkhtmltopdf) وتستخدم عن طريق الأوامر وتدعم التحويل إلي PDF و صور بإمكانيات جيدة ولكنها لا تدعم الـ CSS او لا تدعم من CSS 3 فما فوق رابط الموقع https://wkhtmltopdf.org/ رابط طرق الاستخدام : https://wkhtmltopdf.org/usage/wkhtmltopdf.txt لمعرفة الأوامر من خلال CMD "C:\Program Files\wkhtmltopdf\bin\wkhtmltopdf.exe" --Help "C:\Program Files\wkhtmltopdf\bin\wkhtmltoimage.exe" --Help كما يوجد اداتين ولكن لم يتم التجربة ولكن بحاجه إلي تجهيز حتي تتمكن من استخدامها https://github.com/Sicos1977/ChromiumHtmlToPdf https://github.com/puppeteer/puppeteer

السلام عليكم ورحمة الله وبركاته الأخوة والأخوات الكرام قد تم طرح موضوع قريباً طلب لإخفاء نافذة الطباعة وقد قمت بطرح فكرة لتحويل الجدول إلي ملف HTML وعملت عليها وأضفت لها بعض التحسينات + إمكانية طبعتها الي ملف PDF بصمت باستخدام المتصفح جوجل كروم شرح بسيط 1- يتم استدعاء الكود من خلال الأمر GenerateHtmlReport_TEST 2- يتم التعديل علي sqlStr 3- فيما يخص إعداد نموذج HTML يستوعب جميع الاحتياجات أمر صعب للغاية ولكن يمكن عمل نموذج خاص لكل حالة وسيعمل بشكل جيد فيما يخص النسخة الخاصة بـ البريد الالكتروني فهناك المزيد من التعديلات حتي ننتج ملف يحتفظ بتنسيقه عند وضعه داخل البريد أسئل الله التوفيق والسداد إذا أتسع الوقت والجهد سوف أقوم ببعض التعديلات الأخرى "إن شاء الله" لا مانع من أن يتفضل أحداً علينا بلمسته الطيبة ويضيف او يعدل *ملحوظة فيما يتعلق بنسخة البريد الالكتروني بعد انتاج الصفحة فقط قف علي محتواها وقم بتحديد الكل ثم انسخ المحتوي وألصقه داخل البريد الجديد بالتوفيق Export_Print_Table_To_Html_FN1.accdb

أخي الكريم يوجد مثال بالمرفق فقط قم باستدعاء الأمر ---- GenerateHtmlReport_TEST وستجد ملف HTML علي سطح المكتب إذا كانت الفكرة تناسب احتياجك فالأفضل طلب المساعد من متخصص في الـ FRONT_END ومن ثم سأتمكن انا أو أحد الأخوة الكرام في هذا المنتدي الرائع فبه الكثير من العمالقة المتميزين (ما شاء الله تبارك الله) من إضافة كود الـ HTML للبرنامج لست إلا هاويً فما قمت به من أكواد HTML تم بـ - بعض المعرفة البسيطة - أدوات البحث الحديثة كـ (CHAT-GPT / CLAUDE.AI) - هذا النموذج (https://github.com/kykungz/html-a4-paper) الذي ساعد كثيراً في تحديد الصفحات للتمكن من طباعة كل صفحة بشكل منفصل اخفاء نافذة يتم الطباعة_Test.accdb

ممكن صورة من التقرير أو ارفاق مثال من قاعدة البيانات يحتوي علي التقرير وبعض البيانات

السلام عليكم ورحمة الله وبركاته أخي الكريم لقد قمت ببعض المحاولات - طابعات وهمية وتقوم بإعداد هذه الطابعة حتي تحفظ الملف بصمت - التعامل مع المرجع الخاص بـ (Adobe Acrobat pdf pro) ومع ذلك تظهر نافذة ولكن أخي الكريم الحل الذي قد ينجح إن شاء الله هو ان تقوم بإعداد نموذج بصيغة الـ Html ومن ثم يتم عمل كود لتعبئة هذا النموذج وتكرار المحتوي مع المتغيرات ومن ثم يتم حفظ هذا النموذج ثم يمكنك الوصول لهذا المجلد في أي وقت وطباعته ولكن الأمر يعتمد علي إعداد النموذج الـ HTML وكيف هو أثناء الطباعة وبالمناسبة يوجد دالة لتحويل اي جدول إلي صفحة HTML ولكن اذا كان التقرير بشكل محدد وله أبعاد محدده فيجب إعداد نموذج يتوافق مع احتياجك واختباره في الطباعة أولاً بالتوفيق

السلام عليكم ورحمة الله وبركاته ما تفضل به الأخوة صحيح ويمكن استدعاء هذا الإجراء لتحديث جميع النماذج المفتوحة Refresh_Open_Forms Public Sub Refresh_Open_Forms() On Error Resume Next Dim frm As Form For Each frm In Access.Forms frm.Requery Next End Sub

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

السلام عليكم ورحمة الله وبركاته أخي الكريم @nssj الحمد لله أوله وأخره و الحمد لله الذي هدانا لهذا ، وما كنا لنهتدي لولا أن هدانا الله ، وما توفيقي ولا اعتصامي ولا توكّلي إلا على الله تم بحمد الله التعامل مع المواضع المتأخرة إليك النسخة المحدثة بالمرفقات والفكرة كالتالي: 1- يتم استخراج الكتب وفق المكتبة الكتب والنمط 2- يتم تسجيل بداية كل كتاب داخل النص 3- يتم ترتيب النتائج وفق ظهورها داخل النص اي برقم بداية كل نتيجة 4 - يتم تسجيل نقطة نهاية لكل نص قبل بداية الكتاب الجديد 5 - يتم اقطاع هذا النص 6 - يتم البحث بداخل كل نص مقتطع عن المواضع المتأخر ثم يتم استبدال الـ و فقط لأني وجدت مواضع متأخر تأتي بدون ( إن شاء الله تجد النتيجة جيدة والان الامر متوقف علي قائمة الكتب فاذا كانت تتضمن جميع الأسماء فيمكن ان نعتمد علي هذه الطريقة للبحث داخل النص الجديد بعض الصور قبل : بعد : بالتوفيق Smart_Search_Pages_V11.zip

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

السلام عليكم ورحمة الله وبركاته الاستاذة / صفاء @safaa salem5 تم بحمد الله عمل التعديلات المطلوبة من خلال الأكواد وبإضافة عمودين للجدول ( isPrinted - printCount ) الملف بالمرفقات Safaa_V2.accdb

مكرر

أخي الكريم أرجو لك من الله التوفيق وقد هداني الله لمراجعة الكود مرة أخرى تذكرت ان هناك خطأ مستتر به 😄 وبالفعل لذا تم التعديل وتحسين عمل الكود إن شاء الله يصبح أسرع وأدق النسخة بالمرفقات والخطأ هو انه عند وجود كتاب بديل ضمن قائمة الكتب يقوم باستبداله ثم يخرج و يذهب الي سجل جديد والمفروض انه يكمل ضمن كامل قائمة الكتب ليستبدل جميع البدائل وبالفعل هذا ما وجدت بعد التعديل بالتوفيق Smart_Search_Pages_V10.zip

طيب انا فعلاً لما راجعت الكود وجدت ان فيه خطأ تم التعديل والملف بالمرفق كما أن هناك نص يطبع النتائج ان لم ترده يمكنك حذفه او تعطيله Smart_Search_Pages_V9.zip