Ahmos

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم وبارك فيكم الملف المرفق يحتوي علي [ awsTimer ] وهو [ CLass Module ] والموضوع الأساسي [ awsStringBuilder] وهو [ CLass Module ] و موضوع فرعي [ awsSleepWait_MOD ] وهو [ Module ] و موضوع فرعي الباقي المواضيع الخاصة بهم بالمنتدي [ awsSleepWait_MOD ] - ببساطة وظيفته هي إيقاف عمل الكود لبعض الوقت ولسهولة الاستخدام تم إضافة وحدات للوقت (الوحدة الافتراضية الثواني) و يستخدم هكذا : - Call waitFor(500, wtMilliseconds) - Call waitFor(5, wtSeconds) - Call waitFor(1, wtMinutes) [ awsStringBuilder ] - وظيفة هذه الأداة هو تكوين النصوص الكبيرة بسرعة أكبر بكثير تصل إلي 98 % من الطريقة العادية لن أطيل فالحديث عنها لأنني وصلت إليها حديثاً ووجدت مصادر عده ولكن أغلبها قديم ولم أفحص الموضوع بعناية كبيرة لذا سأكتفي بمشاركة المصادر والوظيفة داخل الكود كما يوجد مثال Advanced_awsTimerTest ملحوظة المديول هام للوظيفة الأساسية لأنه مستخدم لبناء التقرير (النص والـ HTML) المصادر : https://nolongerset.com/string-concatenation-in-vba/ https://nolongerset.com/clsconcat/ https://github.com/joyfullservice/msaccess-vcs-addin/blob/main/Version%20Control.accda.src/modules/clsConcat.cls https://codereview.stackexchange.com/questions/67596/a-lightning-fast-stringbuilder/67600#67600 https://github.com/retailcoder/VBA-StringBuilder/blob/master/src/StringBuilder.cls https://www.vbforums.com/showthread.php?847365-VB6-StringBuilder-Fast-string-concatenation&s=43cda60b1b8cb40b2feaa60b32df951d https://github.com/dragokas/hijackthis/blob/devel/src/clsStringBuilder.cls نتائج التجربة : Normal Test Starts .... Normal String Length is : 944594 Normal Test Takes : 40.794s Normal Test End. SB Test Starts .... String Builder Length is : 894294 sb Way Length is : 894294 awsString builder Test Takes : 638ms sb Test End. AWS StringBuilder is 98.43% faster than the normal way. [ awsTimer ] - وهو موضوعنا الأساسي الأستخدام التقليدي : هو لحساب وقت أي عملية ويستخدم هكذا 1- تهية الـ Class module دخل الكود الخاص بك يتم بطريقتين أفضل الأولي Sub initialize_awsTimer_1() Dim sTimer As awsTimer Set sTimer = New awsTimer Set sTimer = Nothing End Sub Sub initialize_awsTimer_2() Dim sTimer As New awsTimer End Sub بعد ذلك لبدأ حساب الوقت sTimer.startTimer بعد بدأ الوقت يمكنك معرفة الوقت ميلي ثانية في أي لحظة من خلال Debug.Print .elapsedMS ويمكنك أيضاً الحصول علي الوقت منسق بالثواني والدقائق وهكذا من خلال Debug.Print .getFormattedTime(, tuSeconds) كما يمكن استخدام نفس الوظيفة لتنسق اي ميلي ثانية Debug.Print .getFormattedTime(6042, tuMilliseconds) Debug.Print .getFormattedTime(260, tuSeconds) Debug.Print .getFormattedTime(13.15, tuMinutes) ولإيقاف الوقت sTimer.stopTimer بعد إيقاف الوقت سيتوقف العد ولن تتمكن من بدأ او استكمل الحساب إلا بتهيئة جديدة الأستخدام المطور : مقدمة : يوجد لدي بعض الإجراءات التي تحتاج الي ما يقارب الـ 4 ساعات وهي تضم عمل العديد من الأكواد ولمتابعة عمل الأكواد وتسجيل الاحداث ووقت كل عملية والأخطأ والمعلومات كنت أقوم بذلك لكل منها ومن ثم تحليل المعلومات وذلك بشكل أساسي لتحسين وتسريع العملية وعليه فكرت في تطور مديول حساب الوقت ليتضمن الأتي - sTimer.pauseTimer وذلك لكي يتوقف عد الوقت ويستخدم عندما تريد إستثناء بعض الاجراءات مثال إذا اردت إستثناء وقت ظهور الرسالة للمستخدم وإنتظار إجابته عليها - sTimer.startTimer للبدأ والإستكمال بعد التوقف المؤقت - sTimer.addStep "Step1" وذلك لإضافة مرحلة وتستخدم للتحليل فيمكن حساب فرق الوقت بين المراحل كما فالتقرير النهائي يتم تحليل جميع المراحل - sTimer.getStepDiff "Step1", "Step2" وذلك لمعرفة الفرق بين مرحلتين بالميلي ثانية - sTimer.addInfo "UserName", "Ahmos" وذلك لإضافة معلومات كأسم الوظيفة التس ستبدأ او اسم المستخدم - sTimer.addError _ لإضافة الأخطاء أثناء عمل الأكواد "Source", _ مصدر الخطأ "error Number", _ رقم الخطأ "error Description" وصف الخطأ - sTimer.getAwsTimerInfo للحصول علي كافة البيانات - sTimer..exportLog "filePath", txt لتصدير النتائج يوجد نوعين (TXT and HTML) كما يتم التعامل مع 3 مسارات 1- يسمح لك إضافة مسار ملف كامل مع إسم الملف وسيتم التحقق من المسار وإذا امكن إنشاء الملف سيتم الكتابة بداخلة وإذا لم تدخل المسار سيتم اختيار مسار البرنامج وإذا نجح في إنشاء الملف بهذا المسار سيكتب بداخله وإذا فشل سيتم تصدير الملف لسطح المكتب هناك بعض التفاصيل البسيطة مثال للناتج Basic_awsTimerTest داخل مديول awsTimer_Test_MOD #-----------------------------------------------------------------------------------------------------------# ¦ AWS TIMER LOG ¦ ¦ Generated: 27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ COLLECTED INFORMATION ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Key ¦ Value ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦initializedAt ¦ 27/11/2024 05:52:36 PM ¦ ¦currentPath ¦ D:\FOLDER\awsTimer\ ¦ ¦User ¦ UserName ¦ ¦startedAt ¦ 27/11/2024 05:52:36 PM ¦ ¦isoStart ¦ 2024-11-27T17:52:36.000 ¦ ¦startTime ¦ 0.0316 ¦ ¦pausedAt ¦ 27/11/2024 05:52:37 PM ¦ ¦pausedTime ¦ 1013.422 ¦ ¦pausedFormatted ¦ 1.013s ¦ ¦resumedAt ¦ 27/11/2024 05:52:38 PM ¦ ¦RunSub1 ¦ 1013.5207 ¦ ¦RunSub2 ¦ 2024.4509 ¦ ¦Step ¦ 3040.6271 ¦ ¦endTime ¦ 3047.2817 ¦ ¦stoppedAt ¦ 27/11/2024 05:52:40 PM ¦ ¦isoEnd ¦ 2024-11-27T17:52:40.000 ¦ ¦totalTime ¦ 3.047s ¦ ¦filePath ¦ D:\FOLDER\awsTimer\awsTimerLog_27.11.2024_05.52.41_PM.txt ¦ ¦folderPath ¦ D:\FOLDER\awsTimer\ ¦ ¦exportedAt ¦ 27/11/2024 05:52:41 PM ¦ ¦filePath_1 ¦ D:\FOLDER\awsTimer\awsTimerLog_27.11.2024_05.52.41_PM.html ¦ ¦folderPath_1 ¦ D:\FOLDER\awsTimer\ ¦ ¦exportedAt_1 ¦ 27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ STEP TIMING ANALYSIS ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Start Step ¦ End Step ¦ Duration ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦startTime ¦ RunSub1 ¦ 1.013s ¦ ¦RunSub1 ¦ RunSub2 ¦ 1.010s ¦ ¦RunSub2 ¦ Step ¦ 1.016s ¦ ¦Step ¦ endTime ¦ 6ms ¦ ¦startTime ¦ endTime ¦ 3.047s ¦ #-----------------------------------------------------------------------------------------------------------# #-----------------------------------------------------------------------------------------------------------# ¦ ERRORS ENCOUNTERED ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Location ¦ Error Details ¦ #-----------------------------------------------------------------------------------------------------------¦ ¦Source ¦ 12345_Testing add an error._27/11/2024 05:52:41 PM ¦ #-----------------------------------------------------------------------------------------------------------# تعديلاتكم وإضافاتكم واستفساراتكم محل ترحيب. بالتوفيق! بالتوفيق awsTimerApi_V2_FN.zip

لمعرفة إذا كانت قاعدة الحالية تعمل من موقع موثوق أم لا فيمكن تطبيق الأمر التالي ? CurrentProject.IsTrusted يرجع بـ TRUE إذا كانت تعمل من موقع موثوق أما إذا كان لا فلا يعود بـ False إنما تظهر الرسالة التالية ولذلك تم إضافة الأكواد التالية لمعرفة الحالة هناك إحتمالين 1- ان قاعدة البيانات تعمل من مسار رئيسي مضاف للمواقع الموثوقة 2- ان القاعدة تعمل من مسار فرعي ضمن مسار رئيسي مضافة لموقع موثوق + السماح للمجلدات الفرعي مفعل داخل الموقع AllowSubfolders = 1 لذلك أولاً نحتاج إلي هذه الأكواد ويفضل إضافتها للمديول (Helper_Functions) Public Function isPathOrSub(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isPathOrSub = (sBPath = sCPath) Or (sBPath = Left(sCPath, Len(sBPath))) End Function Public Function isSubPath(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isSubPath = (sBPath = Left(sCPath, Len(sBPath))) End Function Public Function isSamePath(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isSamePath = (sBPath = sCPath) End Function ثانياً يتم إضافة الكود التالي الي المديول (awsReg_User_Trusted_Helper_MOD) Public Function isCurrentLocTrusted(Optional ByVal sPathToCheck As String = "") Dim currentLoc As String Dim i As Long On Error GoTo ErrorHandler resetUserTrusted loadUserTrusted If userDeleteLoc Is Nothing Then Err.Raise vbObjectError + 1001, "isCurrentLocTrusted", "Unable to load user trusted locations or there are none available." End If If Len(Trim(sPathToCheck)) > 0 Then currentLoc = Trim(sPathToCheck) Else currentLoc = GetAppPath() End If For i = 1 To userKeysCount If isSamePath(CStr(userDeleteLoc(i)("locPath")), currentLoc) Then isCurrentLocTrusted = True MsgLog "This Path: [" & currentLoc & "] Is Trusted", llinfo, devDebugP, usrMsgLog Exit For Else If isSubPath(CStr(userDeleteLoc(i)("locPath")), currentLoc) And userDeleteLoc(i)("allowSub") = True Then isCurrentLocTrusted = True MsgLog "This Sub Path: [" & currentLoc & "] Is Trusted", llinfo, devDebugP, usrMsgLog Exit For Else isCurrentLocTrusted = False End If End If Next i ExitAndClean: resetUserTrusted Exit Function ErrorHandler: MsgLog "We Received an Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description & vbCrLf & _ "Source : " & Err.Source, _ llCritical, debugState, usrMsgLog isCurrentLocTrusted = False Resume ExitAndClean End Function

أرفق لكم تعديل بسيط حتي يسمح بإضافة مسار كهذا %USERPROFILE%\Desktop\AWSTRUSTLOCATION5\ فكان هدفي من البداية هو توحيد المسارات حتي أستطيع المقارنة ولكن وجدت ان هذا يمنع من تسجيل مسارات في صورتها المتغيرة والقابلة للتمدد وقد يحتاج إليها البعض كما تم إضافة تعديل إذا لفرض حفظ المسار وان لم يكن قابل للتمدد ويكون نوع البيانات الخاصة به هو REG_EXPAND_SZ قد تحتاج إليها في المسارات القصيرة مثل "C:\PROGRA~1" وهو ما يسمي بـ 8.3 Paths ولكي تحصل علي مساراتك الخاصة بعد فتح الـ CMD في الموقع المراد هذا هو الأمر Dir /x وهذا التعديل الذي يسمح بتسجل النص بدلاً من REG_SZ إلي REG_EXPAND_SZ تم أولاً علي الـ awsReg Class Module 1- تم إضافة الكود التالي بالاعلي Private Const FORCE_EXPAND_SZ As String = "awsExpand " Private Const FORCE_EXPAND_SZ As String = "awsExpand " 2- تم التعديل علي VALUE LET PROPERTY بإضافة هذا الجزء ElseIf Left$(CStr(vData), Len(FORCE_EXPAND_SZ)) = FORCE_EXPAND_SZ Then vData = Mid$(vData, Len(FORCE_EXPAND_SZ) + 1) Call RegSetValueEx(hCurKey, ValueName, 0, _ REG_EXPAND_SZ, ByVal CStr(vData), _ Len(vData) + 1) وهنا يتحقق من النص إذا كان يبدأ بـ "awsExpand " سيتم حذفها وتسجيل النص بنوع REG_EXPAND_SZ ثم تم التعديل علي Public Function setUserAppTrustLocation(Optional ByVal locationName As String = "", _ Optional ByVal locationPath As String = "", _ Optional ByVal sDescription As String = "", _ Optional allowSubFolders As Boolean = False, _ -----> Optional forcePathExpandEZ As Boolean = False) As Boolean If forcePathExpandEZ = False Then .value("Path") = sPath Else .value("Path") = "awsExpand " & sPath End If بعد التجربة : تم تسجيل ShortPath بنوع REG_SZ وتم التعرف عليه والتعامل معه بدون مشاكل ما يميز REG_EXPAND_SZ هو تعاملها مع مسارات النظام مثل (%ProgramFiles% - %SystemRoot%) winRegApi_OV2.1.zip

السلام عليكم ورحمة الله وبركاته في هذا الإصدار يوجد ثلاث تطبيقات ( الملف بالمرفقات ) - awsReg_Colorize_VBE لتلوين محرر الأكواد - awsReg_HyperLink_Warning لتفعيل وتعطيل [ application.FollowHyperlink warning ] تم شرح وإضافة الأكواد بالمشاركة التالية بالموضوع الأول الرابط من هنا - awsReg_User_Trusted_Helper_MOD للتحكم بالمواقع الموثوقة Trusted Locations التطبيق الأول : تلوين محرر الأكواد يوجد بعض الأدوات المجانية التي تتيح التعديل علي ألوان محرر الأكواد وتعتمد فكرتها علي التعديل في ملف الـ VBA{Ver}.dll مثال : https://github.com/gallaux/VBEThemeColorEditor ولكن يمكن تحقق نفس النتيجة يدوي او من خلال إضافة قيم للريجيستري يدوي : عن طريق الأكواد إضافة القيم التالية للريجيستري في المسار (HKEY_CURRENT_USER\Software\Microsoft\VBA\7.1\Common) 7.1 هو رقم الاصدار وقد يختلف وتم إضافة المسارات المتوقعة بالاكواد CodeForeColors | CodeBackColors | FontFace | FontHeight | FontCharSet طريقة الإستخدام :call setUpVbeColors(awsDark3) ملحوظة : عند اختيار الخط يفضل اختار ما يدعم اللغة العربية إذا كنت تريد إضافة تعليقات باللغة العربية كما يجب التاكد من الأحجام المتاحة فبعض الخطوط تتيح أحجام محددة مثال بانتظار مشاركة إبداعتكم التطبيق الثالث : إضافة مسار البرامج الخاصة بك في المواقع الموثوقة Trusted Locations لماذا يفضل إضافة المسار الخاص ببرنامجك إلي المواقع الموثوقة ؟ 1- الحد من ظهور التحذيرات أثناء عمل البرنامج وعند كل تشغيل 2- والأهم هي سرعة عمل الأكود فوفق دراسة قام بها بعض المبرمجين فإن الأكود تعمل بشكل أسعر يصل إلي 23× رابط المصدر من هنا اقتباس من المصدر : هل يوجد مكان واحد للإضافة ؟ لا يوجد أكثر من مكان للضافة ولكل مكان ميزاته وعيوبة مثال : فالمسار الخاص بإضافة المواقع الموثوقة لكل برنامج من برامج الاوفيس هو Software\Microsoft\Office\16.0\Access\Security\Trusted Locations ويتغير اسم البرنامج ورقم الإصدار وفق النسخة والبرنامج المستهدف فإذا كان الجذر (ROOT ) هو [ HKEY_CURRENT_USER ] فمن يتأثر بهذه المواقع هو اليوزر الحالي فقط ولكن إن كان [ HKEY_LOCAL_MACHINE] فيتأثر جميع المستخدمين كما ان هناك ترتيب فالموقع داخل HKEY_CURRENT_USER له الأفضلية علي HKEY_CURRENT_USER الموقع الموثوق عبارة عن مفتاح وهو اسم الموقع ويوجد بداخل قيم ويوجد تحت المفتاح الرئيس [Trusted Locations] قيم مثال [USER Trusted Locations Values] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations --------------------------------------------- [Value Name ] : AllLocationsDisabled [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All Trusted Locations are Allowed --------------------------------------------- [Value Name ] : AllowNetworkLocations [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All NetWork Locations are Disabled --------------------------------------------- [Locations] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\awsTLocation --------------------------------------------- [Location Name ] : awsTLocation [Location Number] : 02 [Location Values] : [Value Name ] : Path [Value Data ] : D:\AWSTRUSTLOCATION3\ [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Description [Value Data ] : This Location Has Been Trusted By : AWS REG [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Date [Value Data ] : 17/11/2024/ 10:41:00 AM [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : AllowSubfolders [Value Data ] : True [Value Type ] : REG_DWORD [Value Integer] : 1 [Note ] : All Sub Folders are Allowed ----------------------------------- --------------------------------------------- فإذا تم تفعيل القيمة [AllLocationsDisabled] تحت المفتاح [Trusted Locations] فهذا يعني تعطيل جميع المسارات الموثوقة تحذير هام: أنصح بعدم وضع المسارات شائعة الاستخدم كسطح المكتب والتنزيلات حتي لا نضعف حماية النظام ملحوظة: أكبر عدد مسموح به للإضافة هو 20 لكل برنامج أوفيس الأمثلة موجودة في مديول : awsReg_Trusted_Locations كما يوجد شرح أيضاً في راس المديول : awsReg_User_Trusted_Helper_MOD تم إضافة تعديل علي الكلاس مديول بإضافة دالة جديدة : allValuesKeysDictColl ------------------------------------------------------------------------------------------- أود الإشارة إلي هذه المقاطع داخل الأكواد لأهميتها 1- داخل الكود loadUserTrusted في هذا الجزء يتم إضافة المسارات الموجودة إلي قاموس ليتم التحقق منها لاحقاً وعلية قد يكون هناك مسار مكرر داخل مفاتيح باسماء مختلفة ولذلك أقوم بحذف الموقع الموثق صاحب المسار المكرر هكذا عالجت الأمر وفق تصوري 2- داخل الكود setUserAppTrustLocation تم تعليق هذا الجزء من الكود لعدم إحتياجي له ويمكنك تفعيله إذا كنت ترد ظهور رسالة في حال تم إيجاد اسم الموقع فإذا اجبت بنعم سيتم تغير المسار داخل الموقع الموجود وإذا أجبت بلا سيتم إضافة _1 لإسم الموقع وإضافة موقع جديد ------------------------------------------------------------------------------------------- يسعدني الإجابة علي استفسارتكم الأكواد متاح للجميع للتعديل والإضافات بالتوفيق winRegApi_OV2.zip

أخي الكريم @Foksh شكراً لك علي النصيحة بارك الله فيك أخي الكريم @Moosak أشكرك لك مرورك الطيب كنت بالفعل أنوي تجهيز الأكواد ومشاركتها بمواضيع منفصة ليسهل البحث عنها ولكن تفضل الأكواد التالية للنقطة 1 وإن شاء الله قريباً النقطة 2 روابط للمراجعة : - https://learn.microsoft.com/en-us/microsoft-365/troubleshoot/administration/enable-disable-hyperlink-warning - https://www.slipstick.com/how-to-outlook/disable-unsafe-hyperlink-warning-opening-attachments/ الأكواد بالموديول هي: * hyperLinkWOn - لتفعيل إشعارات الحماية * hyperLinkWOff - لتعطيل إشعارات الحماية * isHyperLinkW - إذا كانت القيمة DisableHyperlinkWarning موجودة بالمسار وتساوي 0 او غير موجودة فهذا يعني ان الحماية مفعلة * msOfficeSecurityPath - لتعود بالمسار المطلوب داخل الريجيستري * awsLink - يقوم هذا الإجراء بتعطيل الحماية ومن ثم فتح الرابط ثم إعادة تفعيلها مرة أخري قمت بالامر هكذا حتي لا نترك الحماية معطلة ولكن يمكن التعديل علي الكود بحيث يتعرف اولاً علي حالة الحماية وإعادتها لحالتها بعد الإنتهاء Option Compare Database Option Explicit Private Const debugState As Boolean = True Private Const msgLogState As Boolean = False Sub Test_awsLink() Dim sPath As String On Error GoTo ErrorHandler sPath = "whatsapp://send/?phone=+2012312313" ' Fisrt Test When The Warning is Enabled hyperLinkWOn ' Make Sure it's Enable Call Application.FollowHyperlink(sPath) ' Second Test When The awsLink it Automatically turnOff then follow The link Then turnOn Again awsLink sPath ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub awsLink(ByVal sLink As String) Dim msgRes As VbMsgBoxResult On Error GoTo ErrorHandler hyperLinkWOff ' To Disable The Hyper Link Security Warning If Not (isHyperLinkW) Then Call Application.FollowHyperlink(sLink) Else msgRes = MsgLog("Something Went Wrong" & vbCrLf & _ "We are unable To Disable The Hyper Link Security Warning" & vbCrLf & _ "Do You Want to Continue ?", llQuestion, debugState, msgLogState, , , mbYesNo, db2Second, SecToMs(15)) If msgRes = vbNo Then GoTo ExitAndClean Else Call Application.FollowHyperlink(sLink) End If End If hyperLinkWOn ' To Enable The Hyper Link Security Warning ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOn() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(0) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOff() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(1) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub ' isHyperLinkW return True if the DisableHyperlinkWarning is not Exist or = 0 Public Function isHyperLinkW() As Boolean Dim winReg As awsReg Dim sPath As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER If Not (.IsKeyExists(sPath)) Then GoTo ExitAndClean .key = sPath If .IsValueExists("DisableHyperlinkWarning") = True Then vResult = .value("DisableHyperlinkWarning") ' Debug.Print vResult(0) ' Debug.Print vResult(1) ' Debug.Print CBool(vResult(0)) If CInt(vResult(0)) = 0 Then isHyperLinkW = True Else isHyperLinkW = False End If Else isHyperLinkW = True End If End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Function ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description & vbCrLf & _ "Source : " & Err.Source _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Function Public Function msOfficeSecurityPath() As String msOfficeSecurityPath = "Software\Microsoft\Office" & "\" & MsAccessVersion() & "\Common\Security" End Function Private Function MsAccessVersion() As String Dim ver As String ver = Application.Version Select Case Left$(ver, 2) Case "16" MsAccessVersion = "16.0" ' Access 2016/2019/365 Case "15" MsAccessVersion = "15.0" ' Access 2013 Case "14" MsAccessVersion = "14.0" ' Access 2010 Case "12" MsAccessVersion = "12.0" ' Access 2007 Case Else MsAccessVersion = ver End Select End Function

سلام الله ورحمتهُ وبركاتهُ علي من أتبع خير الأنام محمد "صلى الله عليه وسلم" الأخوة الكرام تحية طيبة وبعد ،،، أشكر مروركم الكريم وتفاعلكم الطيب أخي الكريم @Foksh مشاركة الأفكار والأكواد فقط. - قد لا يتسع الوقت والجهد لعمل موضوع متكامل الأركان [ قدر المستطاع ] فأفضل المشاركة ثم متابعة الموضوع بالأمثلة او بالرد علي الاستفسارات لأسباب كثيرة أهمها * قد يكمل الموضوع من هو أفضل منك [ - من الناشر - ] * قد تجد في الاستفسارات او الإقتراحات ما يدفعك إلي التعديل ( الجذري او الجزئي) * التأجيل قد يتيح الفرصة للتراخي والتكاسل والوساوس ( يحدث في كثير من الأحيان ) اللهم أعذنا * قد لا يستفيد أحد من الفكرة وخاصةً أنها ليست جديدة والجميع لديه ما يحقق المراد ولكن - قد يستفيد أحد من طريقة كتابة الأكواد او التفاصيل الصغيرة او وظيفية داعمة - قد يجيد غيرك التفكير ويثري الموضوع بتعديلات او أمثلة لم تخطر علي بالك إن أستطاع ( الناشر ) فهو خير وأنصح أن يحشد ما يستطيع من النواية الحسنة الطيبة وأسأل الله لنا الإخلاص في القول والعمل و التوفيق والسداد قبل طرح للسؤال لم أكن أعلم بكل ما يلزم وبعد بحث الحمد لله فهمت أن الأمر ليس صعباً هل انت بحاجة فأجتهد في تحقيق مرادك ؟

أخي الكريم @Foksh الأخوة الكرام صبحكم الله بالخير 1- إلغاء وتفعيل الحماية الخاصة بـ application.FollowHyperlink 2- إضافة مسار البرنامج لـالــ Access\Security\Trusted Locations 3- يعتبر الرجستري وسيط بين الوجهات المتعددة مثال 1 : أعمل بكود لضبط وتحجيم أبعاد الاكسيس والتعامل مع أكثر من شاشة بحيث يسمح للمستخدم بعرض البرنامج علي الشاشة 1 او 2 إن كان متصل بالجهاز أكثر من شاشة وإن كانت الابعاد مختلفة تختلف أبعاد البرنامج وهو يعتمد علي الجداول بشكل أساسي وإن كان هناك أكثر من واجهة تحتاج إلي تطبيق الامر علي كل واجهة ولكن الريجيستري يعتبر وسيط يسمح لك بتمرير القيم وإستدعائها وتعين قيم افتراضية مثال 2 : يمكن إستخدامة في حماية البرنامج الخاص بك فإضافة قيم في الريجيستري تسمح لك بالتحقق من - متي أول مرة تم إستخدام البرنامج (للمدة التجريبة) - إضافة مفاتيح خاصة بكل جهاز - الأفكار كثيرة أظن كدا فكرة الوساطة واضحة وأتمني أسمع أفكاركم 🧠 4- إستدعاء بعض المعلومات التي تحتاج إليها مثل - معرفة مسار النظام الافتراضي [ HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion ] - معرفة جميع الطابعات الموجودة [ HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Printers ] - معرفة الطابعة الإفتراضية [ HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows ] ثم [ Device ] 5 - تغير الإعدادات - تغير الطابعة الإفتراضية - عدم السماح للوندوز بتجاوز إختيار - فيما أذكر يمكن التحكم بالطابعة الإفتراضية من خلال الريجيستري كعمل بروفايل خاص بإعدادات خاصة أرجو لكم التوفيق والسداد والتعامل مع الريجيستري بحذر ويفضل دائماً أخذ نسخة احتياطية للأمان

السلام عليكم ورحمة الله وبركاته الأخوة الكرام بارك الله فيكم تجدون بالملف المرفق قاعدة بيانات بها - [ awsReg ] وهو Class Module للتحكم بالريجيستري [ Windows Registry ] - [ awsReg_Test_Module ] وهو مديول به نماذج لتوضيح كيفية للإستخدام حاولت قدر المستطاع تغطية جميع الإستخدامات - [ باقي المديولز ] هي ضرورية للعمل نبذة مختصرة - مصدر الكود من هنا : https://learn.microsoft.com/en-us/previous-versions/office/developer/office2000/aa155731(v=office.10)?redirectedfrom=MSDN&ref=nolongerset.com - من قام بتعديل التعريفات لتناسب 64x من هنا : https://nolongerset.com/regop-class-for-64-bit-vba/ - قمت بفضل الله ونعمتة ( الحمد كله لله أوله وأخره) 1- دمج وتجهيز الكود بالكامل 😁 2- تعديل نظام عرض الرسائل والأخصاء بالكامل يدعم اللغة ( العربية - الإنجليزية ) 3- تعديل وظيفة allValue لتعود بي 3D Array القيمة والبيانات ونوعها 4- تعديل وظيفة value لتعود بي 2D array البيانات ونوعها 5- إضافة وظيفة allKeysDict - [Get Property] لتعود بالمفاتيح الفرعية داخل قاموس 6- إضافة وظيفة allValuesDict - [Get Property] لتعود بالقيم الموجودة في مفتاح داخل قاموس 7- إضافة وظيفة IsKeyExists لتعود بنعم إذا كان المفتاح موجود (تم إضافة الـ Api الخاص بها) 8- إضافة وظيفة IsValueExists لتعود بنعم إذا كانت القيمة موجودة 9- التعديل علي بعض الأكواد وإضافة وظائف أخري (قد نأتي لذكرها لاحقاً "إن شاء الله" شرح لمثال واحد [ كتابة قيم داخل الريجيستري ] باقي الأمثلة موجودة بالملف Public Sub Test_awsReg_WriteValues() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = "Software\awsApp" ' awsApp Doesn't Exist Yet Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath ' REG_SZ Writing a string value .value("MyString") = "Hello, World!" .value("Date") = Format(Now, "yyyy-mm-dd hh:nn:ss") .value("awsPath") = "%USERPROFILE%\Documents" ' REG_DWORD Writing a numeric value [0 For False] [1 For True] .value("isValid") = CInt(1) .value("myNumber") = 2341 .Options = StoreNumbersAsStrings 'this to store numbers as String .value("strNumer") = 5246 ' REG_MULTI_SZ Writing an array (multi-string value) Dim myArray(2) As String myArray(0) = "Value1" myArray(1) = "Value2" myArray(2) = "Value3" .value("MyArray") = myArray Debug.Print "Values written successfully" End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub النتيجة : الأخوة الكرام الكود متاح للجميع نسعد بتعديلاتكم ومشاركتكم وإستفساركم بالتوفيق winRegApi_V1_FN.zip

سبحان الله الانسان حبيس أفكارة الفكرة مشيت بتسلسل معين وإلا احلها بالطريقة دي الحمد لله والشكر لله الحل ببساطة :- '/// 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