نجوم المشاركات

مشاركة معكم احبتي يوجد حل آخر للحماية بشروط ، او هي شرطين : الاول ان من يعمل على البرنامج لا يشمله الحجب ( لأنه حين يكون متصلا بالجدول من داخل البرنامج ، يمكنه نسخه) الثاني ان تكون الحماية على على الحقول النصية في الجدول فقط الطريقة هي تشفير الجدول عند غلق البرنامج سبق لي من زمن ليس بالقريب ان عملت نوت بوك بريمج صغير لتسجيل الاسماء وارقام هواتفهم وبيانات اخرى .. وكان طلب صاحبي ان لا يتمكن احد من قراءة البيانات عند غلق البرنامج . حماية تشفير.mdb

ادراج اداة للذكاء الاصطناعىchatgpt for Excel تسأل وهي تجيب ادراج اداة للذكاء الاصطناعى.xlsx

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تشفير السجلات في الجداول ، والذي تهدف إلى حماية البيانات من المتطفلين عند محاولتهم استيراد بيانات الجداول . والفكرة تم تطبيقها وإكمالها خلال طرح مشاركة معلمي الفاضل @ابوخليل في رده على أخونا @الحلبي في مشاركة في موضوع سابق . ولكني هنا اعتمدت على الجدول ( EncryptionStatus ) يحتوي حقل واحد ( Status ) من نوع Yes / No لمعرفة حالة التشفير عند تشغيل التطبيق .. ⭐ البرنامج يهدف إلى تنفيذ عملية تشفير و فك تشفير على كافة جداول قاعدة البيانات باستخدام خوارزمية XOR . وتحتوي الأداة على عدة دوال و وظائف تم تقسيمها وتوزيعها بشكل منفصل لتسهيل فهم وصيانة وتعديل الكود حسب الرغبة والحاجة . وبشكل مختصر سأذكر بعض وظائف هذه الدوال تالياً ، ثم ننتقل الى الكود لاحقاً :- الدالة EncryptDecrypt :- هذه الدالة الرئيسية التي تعمل على تشفير أو الغاء التشفير ؛ حيث تستخدم مفتاح التشفير ( المحدد في strKey ) لتطبيق عملية XOR بين البيانات والنص المشفر . الدالة GetAllTables :- هذه الدالة تقوم بإرجاع قائمة بأسماء كل الجداول في قاعدة البيانات الحالية ( طبعاً باستثناء جداول النظام ) . الدالة CheckEncryptionStatus :- هذه الدالة تتحقق من حالة التشفير ، عن طريق التحقق من قيمة الحقل Status في جدول EncryptionStatus . بحيث إذا كانت قيمة الحقل = True ، فإن قاعدة البيانات تكون مشفرة . الدالة EncryptAllTablesIndependently : - تم إضافتها لاستدعائها عند الخلل ( إجراء إحترازي ) .... والعديد من الدوال . كود المديول :- Option Compare Database Public Const EnCodeKey As String = "Officna2024" Public Function EncryptDecrypt(strData As String, strKey As String) As String Dim i As Integer Dim strResult As String Dim keyLen As Integer Dim keyValue As Integer strResult = "" If Len(strKey) = 0 Then MsgBox "مفتاح التشفير غير صحيح", vbCritical, "" Exit Function End If keyLen = Len(strKey) For i = 1 To Len(strData) keyValue = Asc(Mid(strKey, ((i - 1) Mod keyLen) + 1)) strResult = strResult & Chr(Asc(Mid(strData, i, 1)) Xor keyValue) Next i EncryptDecrypt = strResult End Function Public Function GetAllTables() As Collection Dim db As DAO.Database Dim tblDef As DAO.TableDef Dim tblNames As New Collection Set db = CurrentDb For Each tblDef In db.TableDefs If Left(tblDef.Name, 4) <> "MSys" Then tblNames.Add tblDef.Name End If Next tblDef Set GetAllTables = tblNames End Function Public Function CheckEncryptionStatus() As Boolean On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim status As Boolean Set db = CurrentDb Set rs = db.OpenRecordset("EncryptionStatus", dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst status = rs!status Else status = False End If rs.Close Set rs = Nothing Set db = Nothing CheckEncryptionStatus = status Exit Function ErrorHandler: MsgBox "لا يمكنك استخدام هذا المشروع في الوقت الحالي", vbCritical, "" EncryptAllTablesIndependently EnCodeKey DoCmd.Quit Exit Function End Function Public Sub EncryptAllTablesIndependently(ByVal strKey As String) Dim db As DAO.Database Dim tblName As Variant Dim rs As DAO.Recordset Dim fld As DAO.Field Dim tblList As Collection If Len(strKey) = 0 Then MsgBox "مفتاح التشفير غير صحيح", vbCritical, "" Exit Sub End If Set db = CurrentDb Set tblList = GetAllTables() For Each tblName In tblList Set rs = db.OpenRecordset(tblName, dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do Until rs.EOF For Each fld In rs.Fields If fld.Type = dbText Then rs.Edit rs(fld.Name).Value = EncryptDecrypt(Nz(rs(fld.Name), ""), strKey) rs.Update End If Next fld rs.MoveNext Loop End If rs.Close Next tblName End Sub Public Sub SetEncryptionStatus(status As Boolean) Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("EncryptionStatus", dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst rs.Edit rs!status = status rs.Update Else rs.AddNew rs!status = status rs.Update End If rs.Close End Sub Public Sub EncryptOrDecryptTables(ByVal strKey As String, ByVal isEncrypting As Boolean) Dim db As DAO.Database Dim tblName As Variant Dim rs As DAO.Recordset Dim fld As DAO.Field Dim tblList As Collection Dim action As String Set db = CurrentDb Set tblList = GetAllTables() action = IIf(isEncrypting, "تشفير", "فك التشفير") For Each tblName In tblList Set rs = db.OpenRecordset(tblName, dbOpenDynaset) If Not (rs.EOF And rs.BOF) Then rs.MoveFirst Do Until rs.EOF For Each fld In rs.Fields If fld.Type = dbText Then rs.Edit rs(fld.Name).Value = EncryptDecrypt(Nz(rs(fld.Name), ""), strKey) rs.Update End If Next fld rs.MoveNext Loop End If rs.Close Next tblName MsgBox "تمت عملية " & action & " بنجاح", vbInformation, "" End Sub Public Sub HandleEncryptionOnFormOpen() If CheckEncryptionStatus() = True Then Call EncryptOrDecryptTables(EnCodeKey, False) SetEncryptionStatus False End If End Sub Public Sub HandleEncryptionOnFormClose() If CheckEncryptionStatus() = False Then Call EncryptOrDecryptTables(EnCodeKey, True) SetEncryptionStatus True End If End Sub Public Function GetTotalRecordCount() As Long Dim db As DAO.Database Dim tblDef As DAO.TableDef Dim totalCount As Long Dim rs As DAO.Recordset Set db = CurrentDb totalCount = 0 For Each tblDef In db.TableDefs If Left(tblDef.Name, 4) <> "MSys" Then Set rs = db.OpenRecordset(tblDef.Name, dbOpenSnapshot) If Not (rs.EOF And rs.BOF) Then rs.MoveLast totalCount = totalCount + rs.recordCount End If rs.Close End If Next tblDef Set db = Nothing GetTotalRecordCount = totalCount End Function تم تنفيذ الفكرة بطريقتين ، الأولى من خلال الإعتماد على النموذج الرئيسي الذي يفتح به المشروع ( في حدث عند التحميل يتم الغاء التشفير ) وعند زر إغلاق المشروع يوجد حدث لإعادة التشفير لجميع الجداول مرة واحدة وبسرعة مهما كان عدد السجلات . والثانية من خلال نموذج آخر عند النقر على زر Start يبدأ شريط التحميل والذي يعتمد على عدد السجلات في جميع الجداول التي تم تشفيرها بالتقدم من 0 - 100% . وعند اغلاق النموذج يتم اعادة التشفير مرة أخرى . ✔ خطوات الحصول على النتيجة الصحيحة كالآتي :- ✔ انسخ الجدول (EncryptionStatus ) والمديول ( Encryption ) إلى أي مشروع تريده . ✔ تأكد من أن جميع السجلات غير مشفرة . ✔ تأكد من أن حالة الحقل Status هي No . قمت بكتابة الموضوع على عجالة ، وتركت الباب مفتوح للنقاش . Tashfeer 2024.accdb

Dim db As DAO.Database Dim td As DAO.TableDefs Dim sql As String Dim t As DAO.TableDef Set db = CurrentDb() Set td = db.TableDefs For Each t In td ' تخطي الجداول النظامية والجداول المؤقتة If Left(t.Name, 4) = "MSys" Or Left(t.Name, 1) = "~" Then GoTo Continue ' بناء جملة SQL الديناميكية sql = "DELETE * FROM [" & t.Name & "]" ' تنفيذ الجملة SQL DoCmd.RunSQL sql Continue: Next t MsgBox "All records in all tables are deleted" Me.Requery

شكرا للمشاركة اخي ابو بسملة تفضل تعديل كامل على الكود مع المرفق Dim db As Database Dim td As TableDef Set db = CurrentDb() For Each td In db.TableDefs If Left(td.Name, 4) = "MSys" Or Left(td.Name, 1) = "~" Then GoTo Continue DoCmd.RunSQL "DELETE * FROM " & td.Name & ";" Continue: Next MsgBox " all records in all tables are deleted" Me.Requery Database2.rar

السلام عليكم مشاركه م اخى ومعلمى وشيخنا الجليل @ابوخليل التعديل sql = "DELETE t.* FROM " & t.Name

جرب هدا Dim OnRng(), tbl, Irow, ColVisu(), Dates(), Choix() Private Sub UserForm_Initialize() tbl = "Table2" OnRng = Range(tbl).value For i = 1 To UBound(OnRng): OnRng(i, 2) = CDate(OnRng(i, 2)): Next i Irow = Range(tbl).Columns.Count ColVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) ListBox1.ColumnCount = 12 Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 3)) = "" Next i Choix = d.keys '================' رقم السيارة ============== Tri Choix, LBound(Choix), UBound(Choix) Dim iTemp As Variant For i = LBound(Choix) To (UBound(Choix) - LBound(Choix)) \ 2 iTemp = Choix(i) Choix(i) = Choix(UBound(Choix) - i) Choix(UBound(Choix) - i) = iTemp Next i Me.ComboBox1.List = Choix '================' اسم السائق ======================== Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 4)) = "" Next i Choix = d.keys Tri Choix, LBound(Choix), UBound(Choix) Me.ComboBox4.List = Choix Set d = CreateObject("scripting.dictionary") colDate = 2 For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, colDate)) = "" Next i Dates = d.keys Tri Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) Filtre End Sub Sub Filtre() Dim tbl() clé = Me.ComboBox1: If clé = "" Then clé = "*" cléLieu = Me.ComboBox4: If cléLieu = "" Then cléLieu = "*" début = CDate(Me.ComboBox2) fin = CDate(Me.ComboBox3) colDate = 2 n = 0 For i = LBound(OnRng) To UBound(OnRng) If OnRng(i, colDate) >= début And OnRng(i, colDate) <= fin And OnRng(i, 3) Like clé And OnRng(i, 4) Like cléLieu Then n = n + 1: ReDim Preserve tbl(1 To Irow, 1 To n) c = 0 For Each K In ColVisu c = c + 1: tbl(c, n) = OnRng(i, K) Next K End If Next i If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear MsgBox "لم يتم العثور على بيانات مطابقة", vbInformation, "نتائج التصفية" End If End Sub ListBox1.ColumnCount = 12-V2.xlsm

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

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

بارك الله فيك وجعله بميزان حسناتك

لم انتبه لذلك فعذرا شكرا لدعائك واطرائك الملف بحث بجزء من الإسم (1).xlsb

Dim totalValue As Double Dim targetValue1 As Double Dim targetValue2 As Double ' Get values from TextBoxes totalValue = Val(TextBox10.Value) targetValue1 = Val(TextBox11.Value) targetValue2 = Val(TextBox12.Value) ' Check for feasibility If targetValue1 + targetValue2 <> totalValue Then MsgBox "Target values do not match total value.", vbCritical Exit Sub End If ' Initialize banknote counts Dim count200 As Integer: count200 = Val(TextBox1.Value) Dim count100 As Integer: count100 = Val(TextBox2.Value) Dim count50 As Integer: count50 = Val(TextBox3.Value) ' Create arrays to store distribution Dim group1(1 To 3) As Integer Dim group2(1 To 3) As Integer ' Random distribution loop Do ' Reset group values For i = 1 To 3 group1(i) = 0 group2(i) = 0 Next i ' Randomly assign 200 denomination banknotes Randomize For i = 1 To count200 If Rnd() < 0.5 Then group1(1) = group1(1) + 1 Else group2(1) = group2(1) + 1 End If Next ' Randomly assign 100 denomination banknotes Randomize For i = 1 To count100 If Rnd() < 0.5 Then group1(2) = group1(2) + 1 Else group2(2) = group2(2) + 1 End If Next ' Randomly assign 50 denomination banknotes Randomize For i = 1 To count50 If Rnd() < 0.5 Then group1(3) = group1(3) + 1 Else group2(3) = group2(3) + 1 End If Next ' Calculate the total value of each group Dim group1Total As Double: group1Total = group1(1) * 200 + group1(2) * 100 + group1(3) * 50 Dim group2Total As Double: group2Total = group2(1) * 200 + group2(2) * 100 + group2(3) * 50 Loop Until group1Total = targetValue1 And group2Total = targetValue2 ' Display the distribution in TextBoxes or other controls TextBox4.Value = group1(1) TextBox7.Value = group2(1) TextBox5.Value = group1(2) TextBox8.Value = group2(2) TextBox6.Value = group1(3) TextBox9.Value = group2(3) لقد وجدت الحل بحمدلله

تفضل حماية تشفير.mdb

وعليك السلام ورحمة الله وبركاته أيها العزيز مستر @Foksh 😊🌹 شكر الله سعيك .. وبارك الله جهدك .. وأحسن الله إليك .. 🙂🌷 إقتراح من مبتديء لسمو معاليك : 👍🏻😁 مع إيماني بكم الإبداع الذي يحويه هذا الجهد .. إلا أني أقترح عليك أن يكون مع هذه الدرة الرائعة إضافة مثال من الجداول والبيانات لكي يتضح للمتابعين والمستفيدين كيفية الاستخدام ونرى صورة مباشرة للنتيجة .. فبالمثال يتضح المقال 😄🖐🏻

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

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

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