ابو جودي

للاسف اعتقد انه شئ من اتنين ترفع القاعدة هنا ونحولها لك او تقوم بتصطيب اوفيس 2007 او احدث

كليك يمين على قاعدة البيانات واختر خصائص التأكد من ازالة التاشير ان كان موجودا وبعد فتح قاعدة البيانات التأكد من الاعدادت

طيب ودى فكرتى test(2).accdb

من خلال الاكسس نفسه اعمل حفظ باسم واختر ما تريد مثل

ده بسبب اعدادات اللغة المحلية والاقليمية راجع هذا الموضوع للاستاذ @Foksh تجد فيه الحل ان شاء الله لهذه المشكلة العويصة التى تؤرق حياة الناس

اتفضل Database9.accdb

انا الان بت حريصا على استخدام التالى : تشفير كلمة المرور : HashPasswordSHA256 استخدام المعلمات عن طريق : QueryDef هل هذا كافى يا استاذ @شايب لتجنب مثل هذه الهجمات والاختراقات المتقدمه الممكنة كود تشفير كلمات المرور بالشكل التالى Public Function HashPasswordSHA256(ByVal Password As String) As String Dim xmlObj As Object Dim bytes() As Byte Dim hash() As Byte Dim i As Integer Dim result As String ' استخدام كائن MSXML2 Set xmlObj = CreateObject("System.Security.Cryptography.SHA256Managed") ' تحويل النص إلى مصفوفة بايتات bytes = StrConv(Password, vbFromUnicode) ' حساب التجزئة hash = xmlObj.ComputeHash_2(bytes) ' تحويل النتيجة إلى سلسلة نصوص For i = LBound(hash) To UBound(hash) result = result & LCase(Right("0" & Hex(hash(i)), 2)) Next i ' إعادة النتيجة النهائية HashPasswordSHA256 = result ' تنظيف الموارد Set xmlObj = Nothing End Function اما بخصوص استخدام المعلمات عن طريق : QueryDef هذا شكل الاستعلام للتحقق من البيانات Dim db As DAO.Database Dim qdf As DAO.QueryDef Dim rst As DAO.Recordset Dim strSQL As String ' SQL مع معلمات strSQL = "SELECT UserName, IsActive FROM Users WHERE UserName = [paramUserName] AND Password = [paramPassword]" ' إعداد قاعدة البيانات وإنشاء QueryDef Set db = CurrentDb Set qdf = db.CreateQueryDef("", strSQL) ' تعيين القيم للمعلمات qdf.Parameters("paramUserName").Value = Me.UserNametxt qdf.Parameters("paramPassword").Value = Me.Passwordtxt

تقصد : SQL Injection

السلام عليكم ورحمة الله وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل ممكن نكتب الكود بالشكل ده ليكون دالة واحدة فقط ' دالة لتطبيق الإعدادات على النماذج والتقارير Public Sub ApplySettingsToAllObjects() Dim obj As Object On Error Resume Next ' تجاهل الأخطاء لتجنب توقف الكود ' تطبيق الإعدادات على النماذج For Each obj In CurrentProject.AllForms DoCmd.openForm obj.Name, acDesign Forms(obj.Name).PopUp = True Forms(obj.Name).Modal = True Forms(obj.Name).ShortcutMenu = False DoCmd.Close acForm, obj.Name, acSaveYes Next ' تطبيق الإعدادات على التقارير For Each obj In CurrentProject.AllReports DoCmd.openReport obj.Name, acDesign Reports(obj.Name).PopUp = True Reports(obj.Name).Modal = True Reports(obj.Name).ShortcutMenuBar = "cmb_Copy_Sort_Filter" ' قائمة استاذنا جعفر المختصرة DoCmd.Close acReport, obj.Name, acSaveYes Next On Error GoTo 0 ' إعادة تفعيل التعامل مع الأخطاء MsgBox "تم تطبيق الإعدادات على جميع النماذج والتقارير بنجاح!", vbInformation End Sub وزيادة فى الخير واثراء للموضوع هذا الموضوع ايضا لاشرطة الاوامر المختصرة

الافضل استخدام نموذج غير منضم او حقول غير منضمه داخل النموذج المنضم مرفق للتجربة baseF222 .accdb

وفى هذا الرابط شرح الـ Command Line الخاص بالاداة المستخدمه من الموقع الرسمى لها https://zint.org.uk/manual/chapter/4

ابشــــــر ولكن الشرح اجمالا وتفصيلا تجده فى الموضوعات التالية انا فقط كل ما قمت به هو اضفاء اكبر قدر ممكن من المرونة فى كتابة الاكواد والتعامل معها لكن كل الفضل بعد رب العزة سبحانه وتعالى يرجع الى طرح استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @jjafferr صاحب السبق فى هذه الافكار والموضوع وطرحه وشرحه اجمالا وتفصيلا

شكرا لك استاذ @Moosak قصدت وضع الاكواد هنا لسببين اضافة وتعديل بعض الدوال والافكار استخدام اللغة العربية فى التلميحات والكود بقلب جامد بعد موضوع اخونا الاستاذ @Foksh

اولا الاجابة من هنا : ثانيا اهلا بك لانك عضو جديد ولكن نرجو منك مراعاه قراء القوانين المنظمة للمشاركات وذلك من اجل الصالح العام انت يا صديقى لم تستخدم اسما مناسبا لموضوعك وهذا مستقبلا قد يعرض موضوعك لعدم الاهتمام , الاغلاق اهلا بيك بين اخوانك فى المنتدى

الحد الأقصى لطول السلسلة النصية التي يمكن تحويلها إلى رمز استجابة سريع (QR Code) يعتمد على عدة عوامل: إصدار QR Code (Version). مستوى تصحيح الخطأ (Error Correction Level). نوع البيانات (Data Mode). 1. إصدار QR Code (Version): هناك 40 إصدارًا من: QR Code من الإصدار 1 إلى الإصدار 40. كل إصدار له عدد مختلف من الوحدات (Modules) التي تحدد سعة البيانات. الإصدار 1 هو الأصغر 21x21 وحدة ، بينما الإصدار 40 هو الأكبر 177x177 وحدة . 2. مستوى تصحيح الخطأ (Error Correction Level): يحدد مستوى تصحيح الخطأ مقدار البيانات الإضافية التي يتم إضافتها لاستعادة المعلومات في حالة تلف جزء من QR Code. هناك أربعة مستويات: المستوى نسبة تصحيح الخطأ السعة النسبية L (Low) ~7% الأعلى M (Medium) ~15% متوسط Q (Quartile) ~25% أقل H (High) ~30% الأقل كلما زاد مستوى تصحيح الخطأ، قلت سعة البيانات التي يمكن تخزينها. 3. نوع البيانات (Data Mode): يحدد نوع البيانات كيفية ترميز المعلومات في QR Code. الأنواع الرئيسية هي: النوع الوصف السعة النسبية Numeric أرقام فقط (0-9) الأعلى Alphanumeric أرقام وحروف وأحرف خاصة محددة (مثل $, %) متوسط Byte أي بيانات ثنائية (مثل UTF-8) أقل Kanji أحرف يابانية الأقل الحدود القصوى لسعة البيانات: بناءً على الإصدار ومستوى تصحيح الخطأ ونوع البيانات، إليك الحدود القصوى التقريبية: الإصدار Numeric Alphanumeric Byte Kanji 1 41 25 17 10 10 652 395 271 167 20 1,391 845 579 358 40 7,089 4,296 2,953 1,817 Numeric: أرقام فقط. Alphanumeric: أرقام وحروف وأحرف خاصة. Byte: أي بيانات ثنائية (مثل Base64). Kanji: أحرف يابانية.

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

اذا انت مدرك لما سوف يحدث وتريد الاستمرار استخدم الاكواد التالية Function ConvertImageToBase64(filePath As String) As String Dim fileNumber As Integer Dim fileData() As Byte Dim base64 As String Dim i As Long ' فتح الملف كبايتات fileNumber = FreeFile Open filePath For Binary Access Read As fileNumber ReDim fileData(LOF(fileNumber) - 1) Get fileNumber, , fileData Close fileNumber ' تحويل البايتات إلى Base64 base64 = ByteArrayToBase64(fileData) ConvertImageToBase64 = base64 End Function Function ByteArrayToBase64(bytes() As Byte) As String Dim xml As Object Dim node As Object ' إنشاء كائن XML لتحويل البايتات إلى Base64 Set xml = CreateObject("MSXML2.DOMDocument") Set node = xml.createElement("b64") node.DataType = "bin.base64" node.nodeTypedValue = bytes ByteArrayToBase64 = node.Text End Function ' دالة للتجربة Sub TestConversion() Dim filePath As String filePath = "C:\Users\Administrator\Desktop\000000.PNG" ' استبدل بمسار الصورة الفعلي Dim base64String As String base64String = ConvertImageToBase64(filePath) Debug.Print base64String ' سيطبع الناتج في نافذة Immediate End Sub طيب الاكواد السابقة كانت لتشفير الصورة كل ما عليك تمرير قيمتها الى الكود الذى تنشئ من خلال له رمز الاستجابة السريع ولازيدك من الشعر بيتا الاكواد التاليه هى التى تعيد وتعكس العملية السابقة Sub ConvertBase64ToImage(base64String As String, outputFilePath As String) Dim bytes() As Byte Dim fileNumber As Integer ' تحويل Base64 إلى بايتات bytes = Base64ToByteArray(base64String) ' حفظ البايتات كملف صورة fileNumber = FreeFile Open outputFilePath For Binary Access Write As fileNumber Put fileNumber, , bytes Close fileNumber End Sub Function Base64ToByteArray(base64String As String) As Byte() Dim xml As Object Dim node As Object ' إنشاء كائن XML لتحويل Base64 إلى بايتات Set xml = CreateObject("MSXML2.DOMDocument") Set node = xml.createElement("b64") node.DataType = "bin.base64" node.Text = base64String Base64ToByteArray = node.nodeTypedValue End Function ' ودالة التجربة تكون بالشكل التالى على سبيل المثال Sub TestBase64ToImage() Dim base64String As String Dim outputFilePath As String Dim filePath As String filePath = "C:\Users\Administrator\Desktop\000000.PNG" ' استبدل بمسار الصورة الفعلي base64String = ConvertImageToBase64(filePath) ' النص Base64 (يجب أن يكون نص Base64 صالحًا) base64String = base64String ' المسار الذي سيتم حفظ الصورة فيه outputFilePath = "C:\Users\Administrator\Desktop\1\image.jpg" ' استبدل بمسار الملف المطلوب ' تحويل Base64 إلى صورة وحفظها ConvertBase64ToImage base64String, outputFilePath MsgBox "تم حفظ الصورة بنجاح في: " & outputFilePath End Sub طبعا لا تنسى تغيير المسارات بما يناسبك فى وظائف التجربة

طيب مبدئيا لن يتم اضافة الصورة كصورة كما تتخيل السيناريو الذى يحدث قبل ان اجيبك سوف يكون كالتالى الشق الاول : تحديد مسار الصورة وبعد ذلك تمرير المسار الى دالة وظيفتها قراءة الصورة كبايتات باستخدام الوضع الثنائي: Binary , و يتم تخزين هذه البايتات في مصفوفة الشق الثانى : تحويل مصفوفة البايتات الى : bin.base64 ثم استخرج النص المشفر بتنسيق Base64 وتخيل إن الشفرة القادمة دى حتكون نتيجة احد الصور بعد تنفيذ السيناريو السابق : 8e//9b//tx/+zW+OfzjdethdvdyYnq/1DkbBrKF2TOC44FTyRjGn5gs8zQ2/fRDaKs+sVR1Z ClQ51Oi1u5i5aFWBY71pmy3HaDta25abZq2hI0rT1Ns8R71N6wm0Or0u1ANd9wzNETE1B3/s CbvLOI5a7OO4eGzwJnmfxTFVeUGxtPy5oKW6FfEG0Vkf4zKS7Bc9xzFZMONjLhjPD2ZxHCT3 wfEo4j54AW3mx0lxbDiBQa0jPwnH3Gc8LxvTywa6q3wHqHJMdWuPeqyzCH4tSzimd3wp+Br5 e8KfBQp/6aUI8gU4pvucJvvQ/FGS4njedf0zAmHPcRyXjQnHEs1uS2XcoSkDXptGf7ltgxLj 2KKElhtYrme5LsexXGpdQEyq0VqaJ8JKXvAxZJy0WwR0reraikMzEBXLonFuiEm9ELbziowB YpZxEAbPcSxOAsZ0Yhxbjm3Sj6eh2ppqcc+xaDt2pHnZ2MiVdMJx0cgmV7IKFacMH+sN3enY Xt8Jx1591W+sec01r7VO51wntoOxJYrBsK8oEse14TRDCptYc4aqM+D0eT4U+5i3uzMgXYdY nMHxxHanjjdzvRdxnK0c88ohsdLuNRxbkQwBz4+LWvLitVnvZvJeHPPSJYrVwIei99KCkgoK u7xBt08yxjkV5p2C4hW5eCzKz3Rj3FKx87KVl428oucMpxQ0lP4k2NobAsfX9we3j0fI7uFs NG13B2G9jV9L0LDshpJfl3Fj2kQ6qtovVY5lPe45rinFmlKqyWWkqpTLMhePa/l8LQdx5rjV +HlwnOdXIKKfoVTV8BSqaS77ONCt0EDMyDDqFuzrtByv44nKsZAx9Ry3XRxHzIbFuw2/jmP6 z/sb20czjmu5Mu6JvIhjV1YDTYPR2w54Sn6dNMPVdrTeqa93GzzVOOPjV4vHL+YlHIc+D8Hg LovAFRn4bt+jDFxn4ILFwRjx/JHjDWyrSw3BekuhDe1aitqQpLDCs40FjqnRAj4u2qW8WeT9 QSh5aq4olp05jmsh3lGWI/AaONaMFj6sYbZNkvECjr+ocixGuYk5x8m0YxwkFhuZmrHldi3G sRsTuUMlZFvgOCke41UK+1gSPi7peKBBEQ4NCaD98+jhjhtpngPr6+nv+vQTcIwjrzxy+Xy+ UqlZjtZo2YNxfX2zs7c/ODoZnZ5S5fj6AjImHF+dD67PJ4/XkPHk6Xr24Xrt083mt3eb39wB x6sPV5Pb8+H1CTK6Ppncwcdn07uzyd3x8GZf4Lh7unHxhw9/80//7f/ef/I//uf/+l/+i//T v/zH/+y//et/9Luz31xuPe5NLtbHZ6ud/YE7iZS2UQ5qRbeaN0srSo5wbFVp+2h66VbCE7Rs UpMxWAwfU9cXj11kHFtaw1IbplQ3KqFaCmSkGqlyw1BxVcumyTgNC7/7zMgSC/IQnSJk7MU4 9mIcCx/PO4+zOMa7UF7AMUEtkesSlQhkKY5TH7OM5zimf9PHFqSkPk6Kqcs4xpspjm1X4BhR abYG7+oHD1FDxRKOw5+JY/q2sC/juyqwG9DauHmrMWeJxSJLOH6RvAi+2Pk3JIheuxmOU1fJ 54JPlDwQf0dJcfyLBD5WokgK04DFFJ5q3FaRgOdveTG48DfBpDTNBMe2G9puYLtevDLOhUEt 2zURyzVNUaZ18RNBvcUqEJzIOOlFJh/TQaofO4rrKq6jOLaK2LZqwbK2M28sptNcxmEs4zAM g4B0jGvTzorlU4xjy7AhY12xVJrmJqZVUGqKVZbMeJRbUV8BjuNoHH0lr+dLZqHqlNRQMZuG 3YFHHRrftuY31/3Whg8cN1ZjHMfF4KHODo4vg8LzDDRnoNkDJY3TUwWOCbj9WLpO/zmO3RjH 2YFx1FYheo7xQHHPMXDMLE5xTC3FIjF/hX0luy7HMk5YnCbxcUpkOJiaInQKNRkjvAIvmwTH dbAbPqYAyngT19J7+SUFFE5xjHhlyWEcuwVcK8BtcOeG7ORr5krNWKlpKzVlRTHydlBt9e21 7e7x+cbV3b7A8c7+dDButnt+1LK8uor4DTVsqbSxY0vz6zXg2HCKouF47mOjoNC0iqKkliS1 LClIpaZWqnKpLBXh3YKUL0jJzIp4WsU86fxjMjT5mHYGoW2l7ZrmKLqnmgGIrBmhrkUG7Bvj uBv4PPzYEdtKN22rQTEiI8Vx2aiQk7I4Fp3HWRwD6NmujxTHNeC4mO05lj1ZDTX8nbLgtn7g jerBtEky3ug2NnrN1TmOESoeZ4Ycf9bHz3AMGSMgOEAMFvtxBm6coesNgeN4x5wAOB7ads9g qtJEQqOjaC1JiioVj+ZREIsJxwgt1CtYJRo8xbuE5A3CcckuV7w5jmuhwjhWGcdCxhYHF5ba jsnH8ZyKLvIGjrMyjgMuU0NFWjOGjLu22xU4TtJ2HOC4Tp0V3Hls0NiQuY8l2qMX/KBQtU7g WGwu/RXHfyanL8Xxm6d8PlfGg23KQd3qDqPVje7u/vD4dHJ+Pru+FMvyZnfXo5uL4U0Gxx9v 1sHi7x5E5Xj1cY5j8vHN8fDqqH9xMLjaH1ztdc43u2ebg4vth3/zx//mP/vv/M//7//p//7/ /X/9P/5X//l//z/5j//eP/n7V391u/20P7lYG53O2rt9ZxQobbMcyeVALthV/IrJ66WiWRZP R/rVoxbxpKQ981yp5is1j1aV4k05UPWGqdYNKdQqgVry5IJXQ0q+XIGP6+RjKi03Havh2HXb Dm0rcMzApvi0uo5CLbn03+fltooEx3G8YGFaxas4TjtcRZEyI+O0bPwCjp/5eCnPK8dpWwVw LOJ4L+I4aasI8CYtyPtJ0yrwXtRTkeB4KfP7mUTLThF+BccIvm/Zb6MIjosPS68BXjf0O7Nc YE5fb3DwnUy/ivckfYBeecf40aeO8GfMfW+S4XdptGSbPY7YD6+pMI61sK0HPJaWB88mMo5x DBk7TuTaoesEIKuQK3TqUmcvzx52Yh+bHn4iXD2IJ1oIFmuRh/DuerjMBwNX8Smq59I/XhxX B7GXaPwlOH7eVmHaFm0FYrKM0znHlKpivoRjsFhdKSiUHC7o+YpVlPyaVlfNpu71rWhKDRVU PF5/GcdUEiYN04Ushe2+YvcW4nRfwnGPhhln2irspK3CcWlVXzIsmWXszP+0KzQcLdVwsvAu 9jGrlwhLzcQSlJwF8YvB7dnEVCqmbuPsUrykhMypLPqYGiRwnhxhHFOpuBT3UVCr8Qs4Tm5W lmzGMaITjiVtRXdLUVsfrzX2jqZnl1uXN7vI1u5oMG4Ax/W2FTT1sGVEbaPRMeodQ+DYCWgH ad4Yj4a4wceIahKOFb2k6GVFKytqVebdE6tqpayUykqxJGwKJVMhOZdMO14IlCy0mpfyRaVY 1fEsqio2rfLUPYrma0qoG/VlHJOMwaY6lRVFZVHxFMkhHJeMSuFtHEPGKYtFAGWuZDOOC6IH Op5W8RaOFyrHWRyTjxcnVCzOM16OUDL1Swx9xrEwMZWKOQ6FZEzTu/0RWEz7SgLHNMy7b1hd HtfNE7v1tqQ0qjWfxhhncVx2yiWLxiELHwPHBatYsKm0XAs+g2O7iwuG3tb0ZNrx63OOX8Bx 0DXDxfixhilez/ZFuo7XXcRxyzYbFDwBFn2s1Gxan1c2a0hJrxSTnopYxuKB/nr6U59+URzn crliqSCrVUCk3Qtna729/cnZ+dr19ebDnRh1vPF0P3u4Gd9fTZ9upx9uJ083qx9vCcffP259 97D57d3q09Xkbo7j4c1x/+qgdbrTu9wb3uwPrneH17uTm/2nf+vX/+h/8h/8r/8f/7v/8//n v/jP/3//5X/8r/7Z3/7T/0YWx62dnjlwaw2tFEhU+nWlnFYEjgt6qSRwrBbxeyevFopGsUxD KmRaLGzXSka55slKpNEiU18pezLet+jWip4EHJdDpYar6rqKX230up9xHDlwghU6JhJ4kC4F FAMiaVpFuiAvg2O6CjcILdonL7DCADiGt8BQYS9ciPkleiq4X5b7KMiRmYYKGkI833IZb9Yp dj3j44y9sqEPiwtULY5NJm62gGPRWZHgONtWwTim1Xg4Ahz/hDnHomyc4JiaQJIvrWHVGzaN zqDFc/H6Oc6rOBZJqPoGjumr/iVwTAXmbMTiRbob8fczTQLct4KbpV/js/fCQ/9zcYx3jPcL FJOhOfBxpn05xrEatkjGYUfgmDb59bqJjNuW07ScOmQ8x7HjxaMjHMezLZcKvjyEWLRY4FDg GDwF2RBTLCJPj3yt7qv15HLkq6GvBh6i+F7qYwsf8bXKccbHOIDjuDbbViFwjBPj2LZdx7RN zdQ+g2Ntpcil4hjHykoeMuapq3ktVzLy3FwhqSAjvjdj0VjspJ3HaVuFKBXb3DJBOB5qon0C R2IcL/r4VRzzkONnC/LE9tEkY2do8N54vNcXzTmWKU05bpNAfgkc6zTGeEHGIjiSyvilFgsq J1MlmIvBQr1qUJb9Es0ACSsIIVi0VSzguKR4JdkuSFZOsnOSmYOMq9qKYhXcSOqN/Y3d/sHp 6snFBrK5OxrN2r1h1Op5jY7V6FrNnt3qWfBx2FK9es0NKwgNOaYdQEqmS1VkzSqqRkkxyopR UfSKolVl3le8qlUrShk+LrGPqYS8sBXIQtKmixxuIBfKGlRaUWxJdeR4EIqvqqFOleO2K3oq EF6B53BB0aBhRzgPdMWNcVx8CcdkphTH2ZpxBsf5Wq5UK5RwN9RiRa9UTdoIVqadXzX8qTJb jpO0VQRJW0V9Rm3HcUTbcbwyTwRETsKF5GwWcMw+9hnH3tBzkdTEFNpKHTJmHHNGNPB7jmOx lw2HcVyp+qWyW6KNP5wKhToryiWbisd53kWPNg0xi/Axrqr5NfJx8AKOrY5ldQWOdepCbiki ooVjjuNk4DEuvI5jK8Vx0LO8nkPpO36anjvHMa/Ms1u21Ux8HMU+Tvor4GMZPq5Y8HGVHnH2 8Vcc/1mdflEc45TPr1RqJdNRm+1wutrfP1i7vNx+uN//5uPB99/s//DN7nefNj4+zp7uZh/u Zh/v4OPVT3fr394Tjr9/3PzufvbhanyfwfHtce9qv3661bvam9wdTu4Pp/eHs/vDp3/rN//w n/+T/+V/+b/91//V/+3/8v/9L/6H/+qf//1/+g8uf3e79bg3Pl8FjhtbHaVjlkO4tlIJVBi3 YJbh45xaLLGPC3qZVoyqtKd5ySyX7RpSsqhZvuzgh40Lya5cdmsUTyoDyoECHFdDRQpVOdI1 /NKBj2ntRQbHoWeGPiUICcE0raKeyDiD4yRWENohxVhcBgd7kfMStgoeiapwHK4ZA8S063Kr QxGXObT9spj/8FkcZygm3pzjeLGtQjg4g+O4kOzwnOP3l40R4DhZipfBsRB/NP+6LB5LnEWh aAaIk+I4/aJYvQLH6cuMNALH6c1+Jo5fDD6vuAP0Kfhzpd/btyO+82ky7xWzeOn78EXBe80/ iJj3jDSb8PEcxzTDuIloYUuPcUxlY5ZxJ4tj2667NmTMOLYD1/ZFU4VrE44924SPqYTsgqS2 7dP/VQyKY0a+EfnQsF739QanHui0lx5Cg+FAZAXh+rHOTcz4CILF4hTjWJwYx4jnx6VrgWNz PqyCTuRjwrH9LhyryzgWMka4eLxSMrnT0auqAOgAAjagYTG1DTiu0yg3K1lpF4NYVJFFoOQX i8cZHBvLOKb6MeF4YZTb2HYgY6B5oNtd2gGE/sy3ZLNRo9Qz6uWRFD8Tx1pAil2KGOImOPui jCFmce1SeNIFTY/WoqoS8oI8dxHH1H1RUCBmm44rdl4xV6rqiqTnTa/U7FnTjdb2wWj/ZIZs 7o1nG/3RtNUbRe2B2xm6nYHb7tmE46bi1SX42G/U3HqNxh7H+4CUDbusmWXVFDiuIbJOOK5p 1apSFj4ufxbHiVNpfZ5UKKmlKndWKI5Mu9O5iuqreqhTz3HHA4tpO9VB5HZpBR5MDDfTkDUE YHodxyLxEIPXcUxAT3Bc5l2uyiZNq6AFeaHBC/JcZxB447o/a1Pb8VoniqvFn0tmytubhWSa QeEOBYvteYYUHlAIFrvs47hdHi/wnuNYblTKfqHo0uy2ks0+pj/BlZJTLrKPWcZx8MNIOCYf v4xju4sv3DTbus4L/rLJ+lgELy9fwbEV9ezUx0HP9gfuclIct2lZnsCxzZ0z5OP63MdcP1ZE /ZhbLKpFbvKkR/krjv+cTs9xjCOisRiXceELe19y+ZVyuaQbaqMZTWfD/YON6+v9D08nP3x3 9usfT3/z49Gvvhc+Xv94vwYfP93G0yq+f9yGj7+9X3u6nNydDq+OROjyzVH7bGt0c7D2eLr+ 4Wzt8WT17vD+b3/4B/+D/9a/+Nf/i//N//M/+0//X/+H/+7/6j/863/vb09/vFi/3R6ezAaH k3CtWamrBadM/UlureBUc0ZxRc2LZXn4HURDB/VyHk9KWNmsJDiuFPQiziu0HzoFP5kVX6oG cjVQKqEMbVf4shRQVQDPeCOyzdBOZMz7IAQBZAwEi0B+aV6ScWRHFCMIs8x6FcdUFW5RhRiC bBGLPaTdpYjLDGXg8g0c403xYcXx+FMkNdrXcMx17vnAClg5wTENOYZ3lwT8QhpdceE5jhEn ajp4s972GrwzCL4KMZOOA+HR3U6XlHEVWUR8OQa+Vz7HC3FvuaU70ABWvv/4Kl7FMb7M5Cv9 grz0XvhEGR9TeN3e5yMeiDTJI4L80XDcSHAcb3pXV8OGFtJ/pgnHQVun3X47tCAl7qagWE4D OJ5XjoWPHT+uH9sgsUNKJdc6tudYvsM/Gq4Z8f4gdd9AGoHRCI1maNRDPKAc8rEWIr4WeLrP w79phR8VfekjEo1d13c93/EC1ws8P4yDI66HzwoEWxCwYRmGSROSDSgZsal6bDm2bpsqTSKP cSyDDoxj2apKVrmWVo6FjJ/hOPaxkS9Z+INdloHLtgyYegM9HNtgcRM+nroRbYMHH4tuY9Fk HMs49bEoJMf1Yw71HHd1qtEDx8lcNqoHd1UT6WuieEw+FsHloSF2ALE61ExptGh4sFGvUcim ElBLuiUcq25TcxqajRB2FTOUjVBC4tu8kTp1DMO+YoJbGoYvtSADwRZt4ZF2UFCRmOvEL8iY roqqomYMHCO48BqOZTsvWTkmcl4xVqoKfJxTrSKenqPV+ubuYOdwvHs02TmYbO7Cx73RrNkb B72R3x16wHG9bfh1xY+koC5FLdVvyDz2uMr1Y8KxbsHHVdWoZnGcVI7LJaVUhEoTHOeTbuNs z3EGx3gzh3ep6ks41oBgUNjreGBxNKwLHJtNGpBPSKI/IhpVEz+LY9GH+lzGyBKOFWqALtNy 80rNqdEmeckoN7vvuaOQisfTVjgDfHnI8RKFk8wryozjNKmPRWIZ48NS2ZgaiwWOnT4C+1rO wMri2KMqMm0JKf71YZOM8SQnGcc9x3XGsZMvWvkMjqu4ULLLxUUcQ8wV73M47jlGGyCh1X5a Q9brit5IfMxENlqq2aIVe1w51pLtow3uJwaOYWIbOOY4SNh3gqE7z5s4zviY+49Dk/5R4Kuy q9TIx3jQxfo8/m82tx3n5Tw93F9Pf+qTcHA2QsPi+JefcrmVUqmkaUoURePJeG9/5+bm5Jtv rn/z69vf/+769787+82v9r//Zgs4frxdvb+e3l+tPl6vf7jZ+Hi78fFm4+lq9f5scnM8ujwY XhzgfHxNe+N1TzcnN/ubT6fbH8+3PpxtPBzf/PU3f/j3/sF/8C//w//Rv/qf/rP/7H/27/xH /+43/+BXe09H0/P13v64szv0pvVyqOSt8opWyFuVnFleoR3yEhxDw2aNfhMZ5QKgbFWJwi5t lUfjLCz8KNYqYDHikYzxg1cjE0PG1UpAR6SAfulo1DFm6VwYM/gfx4aoGYPFBL60YMwJGsCl 6LWgdgvRUAFGhxTgGFxLE/+PPnVSBseig8KFjNtgcSLjTHAc1zqNpsWdCWwvfChK7Ei6kCb9 FHRBo7sB50F+wLFLF1xPpZ1KAgO4JPQnwf3nWrKT7AASxKvxIOAYwQuBjBs94WNqqwCCI4Q2 o3ZCsFhsv9cCmv0GrdgLAH28AKAuEXzVopG6jvC3Al/UPNSMgYhXI5nCdrLk0dccX3UYxwC0 SFxdpm81ufaLcOx4soh4/ZBRcozjmMUi4hvOSS7H6qWI4/FjnSa+vQgPn07z/2/vzJrbxrID bIk7trsBFzt3cZGsXZa1WbLbnh633d3V00sq05k8zFTN5CEPqVRe85CfnnPOBUCQkmynul2p mmnVVygQuKQoEhQ/HJx7zob4fgpgn8WLBnJs+gUSPM28xHS8Qzw4NYoyFuVIWMDDXGggAyQQ ZNLHnGPlx8qPCoLQTMujNAjta620ljoARBjwiD4XFDZGUlDkRGQpkhbvZqXIPI4MeIYZwiP4 FaDaSiulpQqlihCfUKFQWsiAC59RmTbmSYCDDXMfkNxXgOeLYjaedBxhYYtdaTnSsjE7s9uT 7a5otsF92VYTC1ZsNbytlRzbBCVXNHijJZqWbrOsJwd2MPbiHZnMVbbw04VPcqyimYh2OE6V Q3hgylNMS4wl47S8ItfCn3jGjMMxmLHA+PGI+UNPDV3wY+wRjc2iOXXFAyc2UG88vBxMcpwb OS4QKLWgtq7KAM/PmZ9xlTGVeDJxRezy2OGxLciVCfthUgust5Bj0NYSdF/YSCkT2FnaUPQK WRtZx9zLIzmm3h+w3sUsC910sVrFKq0CS1X46Mdu0HTktm3Sjt1tplpR7oEBY7e80wn68fPl 6fku+PHe4WS+l0/m8XAa5COZ9jme69HlEJTjlOQ4Qjnmfov7baY6TPaYtDxhe9xyuWXxtbSK ht3Ytra3e9v3y1ZQtQraSLZaynGzLscuplV4PJUqx4TjaIJh42gS+0MNcuziJDzX1raNSwcb taIc91q8g3FEk/JHzVwNm3IMK3VQ2be2rUbTbrScRttttVmrDYe037W05cSel3ExVHLs+9NQ z5JonsWLHKv4I0aRN8hTAlYw/7hOqcUrOQYzRjnWJMc+UpNjWMeECmyKDh+NQIMW70hYBtgg XUg4u4MjnE4CjRzbabcbtdpBk1pGY+ZxK+gifqepWg3Z3BaNiialHYMfd0Mjx66beV7O+UDw gcQ/eQT44MogzW5qe6nNEhf8mGeAi6AieyJnou/Kvqf6phIFmTGVoQhHKiYhjsdBPNbIRCc7 BTERTXU41uEo0JhWAXLs+wasRkJ+jPkVUlCWOcPkCtfGKZjgx3hGBG/6b3L8D/BDctx0XUvD ufLO4uTs/Is3r7797qs//vzuT3/68uc/3v74w/k37w6/fL376nZ+dzO/u168vF4Si5dXi7uL OQjx7bP5zdns5nR2czK9PB5fHo4v95d3p4dfXp6+e3H2/haWtz++ff/nn/71P//6b//9H//+ P//1zV9+ev7+dnl9OD5b5IfTdH/sz5Jeypqq94SBFpdgHkVzJcei00BAhWlCXuTAshvYaMlB r4uZ/viRI+wefPxCnCvQi7pWbMFJKlZHjoUTS5dSKqkxWEgCCtIDVgoy11fJQMUlUa5omj9N 1DM5u1jtATtIR6FAJ1jpUQVsrMuxn/XRfT8OqHPu56lMwTnwmjX2M0sikcQAyEexBSwEzQnA jV4UOqF2NDgxlQ4IlMHVPouKhsBF0kgcyjiihJDETzCtgrwWDTjJxwisbDJOkkmS0q50ECeD MBlECPoxPUKOkk3bQZ3DbICKTGCCMvzhNIYCzGvQ9rJ1H5yTrPwYX2EGWqwQrotElwIKMK+F kD8FcmJLBT1aoh8byI8LM67eNVop3kqT8kHpFuC4Jo6LoXqqm+GGWGnuM1E9GdTxKoRcUgg3 jMRneA8Uejye6WSPqnTTawsnHhyvJ1RoHoDLahmanCI4qnGLpwM3DDAYTAePgWR982msA88z gQNMYpJSICJfhAoLwmAFDOYFnhu4FawAszxNxM7UHfd8Tr2ppam7DCtewN2AOcpzhGNJx1KO oxwbL25iCVL4lmqLdps3W6zRZI2Gt13IsWnuClAKMs7SA1fzmyztyb4NCgtGG01l0fyZgmSw TAASArhZVGcbU0oxAOs71N8OQc31xwwexBCMAPhuLhtxFVOFqgn1dYoZeHLgiLwGZlB4qMIr BMFVwmTCRIzw2ANFZgUWx0SLklV2BMahMTnYlCV+CLcAfbeKB2+MqYCRRos3NhotXgNOPwLE EY2e+8T2njDZCCIrzlk+lujH+32S491nF0/Prw5OL3YPTuArB07MZZx76YD1RzIfiWTg6dTy EzDjntQdHpiGebAES7ZF4ErfE8plEq8nWEVaRZMKHjfAjB/MZCAbxhAyurK5aW213GY9rQKO Rh4xECMwpGAA5hRq6oqn+gEYMzZO03Dg4bS5iq6iGVp0SRP1yFxer6DfVQDrG3tBnSlBuek2 2l6jDWd6qpJjx8sY+CKYoj8BfwU/jqN5Ei+yZPkQizRZJPEcHLoU30+AcirAjIs8CkMVMAYt jucaW+egH+MwfyrVWFTgtLwhJgR7me0kPSvuduNuO+y1dLcRtBt+u6FaW6L5RDTqbMtWU+G8 vQ58OyeOnXluzr2BZENl4EMlBpLnnCUeajHCeOrCZ0SkHgIrGRNw8pAzmXOVC9WnpncDhX09 RjjTLhxTbHgCBhwC8TTKZgmQzpJkB4iBaAK7Kj+uQTPzVC5lhj3zyI/hyTDwY3O5oCN+m5D3 D/JjIscOfD/58Wg8Ozw6fXH34qv3v/vhxzc//fTy++8v378/evN6eXszvbqYXJxPLp5NLoGz 8eXp+PJkcnk8uTyaXBwQ++Pn+/nJIjueZSez6eX+01fPTn5/ffbuFrj+7s3rf/762z//0/d/ /fmHv/3L9bevd2+O+0c7ydNRtOyHi1xOIivhTd8qtNhrgRmXctwGLW6KHpkx0Gv74L4kx0Dg YE4FnIzW5TiCAWDGnUqOnXU5dmPtxqGH0lnKcZzDP2aVDJFNOca4plE38gmN0/hQBWouVfKL 5Th+QI6rLSjHcLPQZZAYLBqwkuMS7bshzpcCUHQiCpCTHPtJEiSpTjHiq7NhlI4McQoGPCRg ZVwAcpzAyjBJhiDHYMZmGYIWx0iY9EmXaRcVhksAcO50EIEul8NWJHgXQ7kxC6LUD1N4qVWA hXiFH3LyY8wM2ZBj/ejsvUchOX7QjIEq5F/FjGEdxLeg2Eu6SW+okeOqE+GnAI/5KWzcpZRj 48f4q2tgvkoxuPBjSgsxkM2XcW7sX4gvGuWruGtoD/w4xIgvB7AXOozBaw6O1m4YemHIIjhz oA/I5hO4DwxIJByreIgGeFkmUl4o3JC7moEQkwSDgtiOdtyQgBXtwE3a5To+DAMVFm4gXTy7 U7QibJ9ZyrNIjnvgxwSsdCV8S2GRRwy5sVaTtRoefGNtY8N5Z2sVOabiFeDHPdUECzQdj8MR i8YinkpQZCAkUSY5DuJCjqXJlNiQY5xOh5FgkGNM7TaQGXMyY3Bfl6hm05vuAxVleYp1OZYg x6mrUuPHnBAqlUjCZcJFbGAs8ljkkhxjosW6HHcFVh3u8KQD8lp32cf4qBzXBdooshlZl2OT esHjLo86PGwDrmqAGTtsC4xWJzaIbzYUg6k/20uPznZOzpcgx8+vDs+e7+2fTCdz+FfBw8xO +l5/LPOxSIcM5Tju+UaOsWaFoSN8S/iODFyhHCZsm6Mc92pyvNWjTN8NOaamdIUZ064qctxh HUv2bGU7WD/b4fBfB+R4AJJEpSpGkaZSFSKTHnx3hC640YYcd36xHGOLK5xFsyHHHhtwORL+ BJxVg8hGsyheJOTB96mbcVQ34EfAvh41OZaE0kaO4SNA5SlKOdZGjoOp9Cd1OcYEIV7KcS/q dciMm0EHcyONGfPGE779hG8RsIJy3FDtFshxVMpxf0OOpRgIlOOU8cQjWKHFKayAFjOZcYkN n2Fp5Fj6A0ly7AdUgwLluDRjMOB4EqU7icHIMegyyTHuhfF1KJCs4DHrfgxyjInmVKKkLsc4 +RLedwDezd9+/t5+jBzbtiNl2B9M9vYPLq6ef/Hm9t3XN++/fv727fGrV4urq9HZWf/kOD8+ zI8PgOx4Pz3ezY6X+clufgLLRX4y75/MYRk+HQW7A707gJvz66OjNxenb2/O3r64+ObVzXe/ e/nD27s//P76m9d7L07AjINZJqcxaLE/jflI92LWVDU5htMyOPhIjo0T/x/lmMx4U44llW4N cCIRziiKvJUc9wUI8Zoc95XGS9IbcqzCQOB8vlDd0xqgMJvPI8cA3iwDyetyXAO2UKUtAygy 3rGUY51mockSzoZhUhAnaMDECIV4BdwsdoEZkxz3Q9BiAtbNRiABjF6XW6phFVG8Gh/Vd0VZ oBO/9OPPJMcbZmwAA66ZJZrx/b2gmCaIi3IM7zKNrL/pj7GuuY+ycRTdu9emHK/dxUS4V39C 8QjFgEfaCgKo/pgfUtx9Y1jxspiw+qfJcXmgBgyvzCiaywJKQT0p0YAtB774Q8fBBCdawjqA fgwDmBNwJxBOIB1NXfq0tANuKdaTbk84dbrC6QirzbuYqcmoJn85RQa+rp4YP6b8ikKOnSdd 2WRRV6Q9P7f1wItGHPy46P88FZhosSnHlCyxIcdkxgrTi3Hqz3rM2JixcV9YqTtxxeNyjOnC binHFDZGM6a2bYkQcQELyY8peIxZFpty3AZ4gvJad9zH+KgcVwPqwOBKjqkJSDW3ryviNsCC psO3XLHNg7ZOQY5djApP1HQZ7x+Pj58tMHJ8eXB6vvv0aDLaCaPcCxIryp18JFCOKXIcJL0g RjkWQZspQ4errvFjJh2X2xZNyFvJsfWQHMN6Jabl9kKO7WbH6/R4F9N16KKEF3qlHIM2oRyH oxBuykyymLlhETv81eW4QWWA1+UYO8ZJOOkag7ZSveEdHc9j8OD7rMzYVGf7uB+bjnelHMPR PoXDWz4mx7ClcOgpyHrlx1wOGe+7Ro67YMZBYcagv1uSYsZY5Ljqk7eFNd1ECwaAQ6/J8fCe HPc5y0iFwYwNKUdPJcCM0YkrUI5NozssXQyCG45WZhyOAvBgcuIiZgxmHE/DUo6LMRWa5JhS kMGP8XfBb+Qp92IPi1v7Vrcmx+U/HCpO8tvP39uPSauwLItzlWbZbD4/Pjm4vDq9e3l4d7d7 fTU5O8sODvRyGSwX/nKuljO12JGLqViM5GKoliN/OQx2h3pvCFoM+ItczlIxS+P98fh8b+/u 7PDNxcmX12df3Z6/uzt/++Loi4vl9VF+uOPPUrvvO7nyBr4YaVh2Yrdh0ircpjFj4MNy3I2K nIpOgJ9Pk+b/QTmu2n19mhyHGfpx7aL//7scA+DELiivcd/KjGGFcEPtVbkWZMkfkGNKIy7y JUptHcbxaEXpxIa6GRvqvvthOd4waVrpw0YEBoAfh6mvE0kvNfYruZ9W8UvkGJzYsDEAw6gE 5Y7jFjJpg200MaKDBCwQJ0F+TI5hl/FUtOqiVPOHuX8UAcWBVAC/vTJUlGNzLwMK7or15/aI HKMZl08SgDHwCmwMwF2/ihyDVWCQ2C5s2Mhx5cePyrGwA2YptyudDrNWcLsjnLawQErAiQ1g J0aO6evqITnm227QIj+2/NzRfQ+7Z6EfY+Q4MpkVm3Js/JhaPRNkBlxSsgQ6cREYxmixyIFS dvvGjw2VGQMflOPCjz9JjnmMs/Q+nxzXY8bFrEECbtL2Ine5mNuXWdQ6pCeTLsB1y5PbTDVl 2IkykGPMIU6HfLgTLPf7h6ezs+dPn10eHD9b7h2OBtNAp9hEGjQ6HbJsxNKBizUrEkvHNmZW mAl5JudYdZmitGNuOcwy1SpIjlstp9WwyxoRH5NjgDIrsGBFj3V6oosZ7cJytSsy5fdN5Dg0 oBybahVGjgO7V/rxrynHolnLOXa8FDsqiyFXIMdYQcIHlwWpjTC/IgYbrgNbUHmx+gQWLf4c cowfCpJj8ylA6IPAB66X206GkakH5BjAOsdFnzyUY9lqBDU5zpk7EF5pxpUci74QOdgwRydO OYaKyYkNqK0VD8vxGtFYkxBXhAbw4xJtKBMt6n5cxI+9xIP/V7aGtx7PyYsOeYBJN3ca/wuy 3LE3KuHM/gAAAABJRU5ErkJggg== انت مدرك ليه كتب لك الاستاذ @ناقل فى الملاحظة فى مشاركته فى الرد عليكم : حجم البيانات المشفرة (Base64) يمكن أن يكون كبيرًا، مما يجعل QR Code أكثر تعقيدًا طيب وده اللى هيظهر عند المسح للكيو اركود للصورة : شفرة (Base64) اللى وضعت لك لها مثال ولاصارحك الرأى : هذا اصلا ان استطعت تحويل الشفرة هذه فقط الى رمز استجابه سريع هل انت مدرك لما سوف يحدث ؟ هل ما زلت تريد الاستمرار ؟

ومشاركة مع استاذى واخى الحبيب الاستاذ @Foksh طريقتى المتواضعة zint barcode generator V2.zip

تحديث جديد للكود السابق الذى يقوم بمعالجة التواريخ غير المنظمة وتحويلها إلى تنسيق صالح Function RectifyDateFormat(inputString As String) As Variant ' تمكين معالجة الأخطاء On Error GoTo ErrorHandler ' إزالة الفراغات الزائدة من بداية ونهاية السلسلة inputString = Trim(inputString) ' استبدال الأرقام الهندية بالأرقام العربية Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' استبدال الرموز غير القياسية بواصلات Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "-", "#", "@", "+", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' تنظيف الواصلات الزائدة inputString = CleanHyphens(inputString) ' تقسيم السلسلة إلى أجزاء التاريخ Dim strDateParts() As String strDateParts = Split(inputString, "-") ' التأكد من أن السلسلة تحتوي على ثلاثة أجزاء If UBound(strDateParts) <> 2 Then MsgBox "التنسيق غير صالح. يجب أن يحتوي التاريخ على ثلاثة أجزاء (يوم، شهر، سنة).", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' تعيين الأجزاء إلى متغيرات مع إزالة الفراغات الزائدة Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' التأكد من أن الأجزاء يمكن تحويلها إلى أرقام If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then MsgBox "التنسيق غير صالح. يجب أن تكون أجزاء التاريخ أرقامًا.", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' تحليل أجزاء التاريخ Dim intDay As Integer, intMonth As Integer, intYear As Integer AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' التحقق من صحة التاريخ If Not IsValidDate(intDay, intMonth, intYear) Then MsgBox "التاريخ غير صالح. يرجى التحقق من اليوم والشهر والسنة.", vbExclamation, "خطأ" RectifyDateFormat = Null Exit Function End If ' إنشاء التاريخ وتنسيقه RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ErrorHandler: ' معالجة الأخطاء MsgBox "حدث خطأ أثناء معالجة التاريخ. يرجى التحقق من التنسيق المدخل.", vbExclamation, "خطأ" RectifyDateFormat = Null End Function '************************************************************************************************************************************* ' Function: ReplaceSymbols ' Purpose: استبدال الرموز غير القياسية بواصلات '************************************************************************************************************************************* Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function '************************************************************************************************************************************* ' Function: CleanHyphens ' Purpose: تنظيف الواصلات الزائدة '************************************************************************************************************************************* Private Function CleanHyphens(inputString As String) As String inputString = Trim(Replace(inputString, "--", "-")) Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function '************************************************************************************************************************************* ' Subroutine: AnalyzeDateParts ' Purpose: تحليل أجزاء التاريخ لتحديد اليوم والشهر والسنة '************************************************************************************************************************************* Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' تحليل الأجزاء بناءً على الطول If Len(strPartOne) = 4 Then ' السنة أولاً (تنسيق: YYYY-MM-DD أو YYYY-DD-MM) intYear = CInt(strPartOne) If CInt(strPartTwo) > 12 Then ' تنسيق: YYYY-DD-MM intDay = CInt(strPartTwo) intMonth = CInt(strPartThree) Else ' تنسيق: YYYY-MM-DD intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) End If ElseIf Len(strPartThree) = 4 Then ' السنة أخيراً (تنسيق: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' السنة في المنتصف (تنسيق: DD-YYYY-MM أو MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' جميع الأجزاء أرقام صغيرة (تنسيق: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' معالجة السنوات المكونة من رقمين If intYear < 100 Then If intYear >= 50 Then intYear = intYear + 1900 Else intYear = intYear + 2000 End If End If End If End Sub '************************************************************************************************************************************* ' Function: IsValidDate ' Purpose: التحقق من صحة التاريخ '************************************************************************************************************************************* Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' التحقق من صحة اليوم والشهر والسنة If intMonth < 1 Or intMonth > 12 Then IsValidDate = False Exit Function End If If intDay < 1 Or intDay > 31 Then IsValidDate = False Exit Function End If If intYear < 1900 Or intYear > 2100 Then IsValidDate = False Exit Function End If ' التحقق من عدد الأيام في الشهر Dim intDaysInMonth As Integer intDaysInMonth = Day(DateSerial(intYear, intMonth + 1, 0)) If intDay > intDaysInMonth Then IsValidDate = False Exit Function End If IsValidDate = True End Function

اثراء للموضوع ومشاركة مع احبابى واساتذتى العظماء اليكم تجميعه بأهم دوال الوقت الوتاريخ مجمعة فى وحدة نمطية عامة واحدة Public Function IsValidDate(ByVal dtDate As Date) As Boolean ' الغرض: التحقق مما إذا كان التاريخ المقدم تاريخًا صالحًا. ' الوسائط: dtDate - التاريخ المطلوب التحقق منه. ' الإرجاع: True إذا كان التاريخ صالحًا؛ وإلا False. ' مثال الاستخدام: ' If IsValidDate(txtDate) Then ' ' قم بعمل شيء ما مع التاريخ الصالح ' End If On Error Resume Next IsValidDate = IsDate(dtDate) On Error GoTo 0 End Function '1 Function FormatDate(ByVal vDate As Variant) As String ' الغرض: إرجاع سلسلة نصية بتنسيق التاريخ المستخدم بشكل طبيعي في . ' JET SQL. ' الوسيط: قيمة تاريخ/وقت. ' ملاحظة: يتم إرجاع تنسيق التاريخ فقط إذا لم يكن هناك مكون وقت، أو تنسيق التاريخ/الوقت إذا كان موجودًا. ' ' مثال الاستخدام: ' a = DLookup("[some field]", "some table", "[id]=" & Me.ID & " And [Date_Field]=" & FormatDate(The_Date_Field)) If IsDate(vDate) Then If DateValue(vDate) = vDate Then FormatDate = Format$(vDate, "\#mm\/dd\/yyyy\#") Else FormatDate = Format$(vDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function Function GetAmericanDateFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأمريكي (MM-dd-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق MM-dd-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' ' ' مثال الاستخدام: ' formattedDate = GetAmericanDateFormat(SomeDateField) If IsNull(vDate) Or vDate = vbNullString Or Len(vDate) = 0 Then GetAmericanDateFormat = Format(Date, "MM-dd-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetAmericanDateFormat = Format(CDate(vDate), "MM-dd-yyyy", vbUseSystem) Else GetAmericanDateFormat = "" End If End Function Function GetDateInEuropeanFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأوروبي (dd-MM-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق dd-MM-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' مثال الاستخدام: ' formattedDate = GetDateInEuropeanFormat(SomeDateField) If IsNull(vDate) Or Len(vDate) = 0 Then GetDateInEuropeanFormat = Format(Date, "dd-MM-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetDateInEuropeanFormat = Format(CDate(vDate), "dd-MM-yyyy", vbUseSystem) Else GetDateInEuropeanFormat = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '2 Public Function ConvertDate(ByRef strInputDate As String, ByVal strConversionType As String) As String ' الغرض: تحويل التاريخ بين التنسيق الهجري والميلادي بناءً على نوع التحويل المحدد. ' الوسائط: strInputDate - التاريخ المراد تحويله كسلسلة نصية. ' strConversionType - نوع التحويل، "H" للتحويل من الهجري إلى الميلادي، "M" للتحويل من الميلادي إلى الهجري. ' ملاحظة: يتم تعديل التاريخ وفقًا لليوم التصحيحي من الجدول tblAdjustHjriDate. ' ' مثال الاستخدام: ' convertedDate = ConvertDate(txtHijriDate, "H") ' تحويل من الهجري إلى الميلادي ' convertedDate = ConvertDate(txtMiladyDate, "M") ' تحويل من الميلادي إلى الهجري Dim intCorrectionDay As Integer Dim intSavedCalendar As Integer Dim dtConvertedDate As Date Dim strFormattedDate As String On Error GoTo ErrorHandler ' الحصول على يوم التصحيح من الجدول intCorrectionDay = DLookup("[AdjustDay]", "tblAdjustHjriDate") ' التحقق من صحة التاريخ المدخل If IsValidDate(strInputDate) Then ' تعيين نوع التقويم وتحويل التاريخ بناءً على نوع التحويل If strConversionType = "M" Then ' الميلادي إلى الهجري strInputDate = Trim(Format(DateAdd("d", -intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 1 dtConvertedDate = CDate(strInputDate) VBA.calendar = intSavedCalendar Else ' الهجري إلى الميلادي strInputDate = Trim(Format(DateAdd("d", intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 0 dtConvertedDate = CDate(strInputDate) VBA.calendar = 1 End If ' تنسيق التاريخ المحول كسلسلة نصية strFormattedDate = Format(dtConvertedDate, "dd/mm/yyyy") ConvertDate = strFormattedDate Else ConvertDate = "" End If Exit Function ErrorHandler: If err.Number = 13 Then MsgBox "تنسيق تاريخ غير صالح. يرجى التحقق من البيانات المدخلة.", vbOKOnly + vbExclamation, "خطأ" Else MsgBox "حدث خطأ غير متوقع: " & err.Description, vbOKOnly + vbCritical, "خطأ" End If Exit Function End Function '----------------------------End------------------------------------------------------------------------------------------- '3 Public Function ConvertNumberToLocale(ByVal strNumber As String, ByVal strLocale As String) As String ' الغرض: تحويل الأرقام بين النظام العددي العربي والإنجليزي بناءً على اللغة المحددة. ' الوسائط: strNumber - السلسلة الرقمية المراد تحويلها. ' strLocale - نوع اللغة، "Ar" للأرقام العربية، "En" للأرقام الإنجليزية. ' ملاحظة: تقوم بتحويل الأرقام من العربية إلى الإنجليزية والعكس. ' ' مثال الاستخدام: ' txtNumberToArabic = ConvertNumberToLocale(txtNumber, "Ar") ' تحويل الأرقام الإنجليزية إلى عربية ' txtNumberToEnglish = ConvertNumberToLocale(txtNumber, "En") ' تحويل الأرقام العربية إلى إنجليزية Dim strConvertedNumber As String If strLocale = "Ar" Then ' تحويل الأرقام الإنجليزية إلى عربية strConvertedNumber = Replace(strNumber, ChrW(48), ChrW(1632)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(49), ChrW(1633)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(50), ChrW(1634)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(51), ChrW(1635)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(52), ChrW(1636)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(53), ChrW(1637)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(54), ChrW(1638)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(55), ChrW(1639)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(56), ChrW(1640)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(57), ChrW(1641)) ' 9 ElseIf strLocale = "En" Then ' تحويل الأرقام العربية إلى إنجليزية strConvertedNumber = Replace(strNumber, ChrW(1632), ChrW(48)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(1633), ChrW(49)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(1634), ChrW(50)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(1635), ChrW(51)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(1636), ChrW(52)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(1637), ChrW(53)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(1638), ChrW(54)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(1639), ChrW(55)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(1640), ChrW(56)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(1641), ChrW(57)) ' 9 End If ConvertNumberToLocale = strConvertedNumber End Function '----------------------------End------------------------------------------------------------------------------------------- '4 Public Function GetMonthName(ByVal dtDate As Date, ByVal strLocale As String) As String ' الغرض: إرجاع اسم الشهر بناءً على اللغة المحددة. ' الوسائط: dtDate - التاريخ الذي يتم استخراج اسم الشهر منه. ' strLocale - نوع اللغة لتحديد لغة اسم الشهر. ' "HJ" للهجري، "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة، ' "Cpti" للقبطية، "Syr" للسريانية. ' الإرجاع: اسم الشهر باللغة المحددة. ' ' مثال الاستخدام: ' txtMonthNameHijri = GetMonthName(txtDate, "HJ") ' اسم الشهر الهجري ' txtMonthNameArabic = GetMonthName(txtDate, "Ar") ' اسم الشهر العربي ' txtMonthNameEnglish = GetMonthName(txtDate, "En") ' اسم الشهر الإنجليزي ' txtMonthNameEnglishShort = GetMonthName(txtDate, "EnShrt") ' اسم الشهر الإنجليزي المختصر ' txtMonthNameCoptic = GetMonthName(txtDate, "Cpti") ' اسم الشهر القبطي ' txtMonthNameSyriac = GetMonthName(txtDate, "Syr") ' اسم الشهر السرياني Dim strMonthName(12) As String ' التحقق من صحة اللغة المحددة If strLocale <> "HJ" And strLocale <> "Ar" And strLocale <> "En" And strLocale <> "EnShrt" And strLocale <> "Cpti" And strLocale <> "Syr" And strLocale <> "No" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'HJ'، 'Ar'، 'En'، 'EnShrt'، 'Cpti'، 'Syr'، أو 'No'.", vbExclamation, "خطأ" Exit Function End If If IsValidDate(dtDate) Then ' تحديد أسماء الأشهر لكل لغة Select Case strLocale Case "HJ" ' أسماء الأشهر الهجرية strMonthName(1) = "محرم" strMonthName(2) = "صفر" strMonthName(3) = "ربيع الأول" strMonthName(4) = "ربيع الآخر" strMonthName(5) = "جمادى الأولى" strMonthName(6) = "جمادى الآخرة" strMonthName(7) = "رجب" strMonthName(8) = "شعبان" strMonthName(9) = "رمضان" strMonthName(10) = "شوال" strMonthName(11) = "ذو القعدة" strMonthName(12) = "ذو الحجة" Case "Ar" ' أسماء الأشهر العربية strMonthName(1) = "يناير" strMonthName(2) = "فبراير" strMonthName(3) = "مارس" strMonthName(4) = "أبريل" strMonthName(5) = "مايو" strMonthName(6) = "يونيو" strMonthName(7) = "يوليو" strMonthName(8) = "أغسطس" strMonthName(9) = "سبتمبر" strMonthName(10) = "أكتوبر" strMonthName(11) = "نوفمبر" strMonthName(12) = "ديسمبر" Case "En" ' أسماء الأشهر الإنجليزية strMonthName(1) = "January" strMonthName(2) = "February" strMonthName(3) = "March" strMonthName(4) = "April" strMonthName(5) = "May" strMonthName(6) = "June" strMonthName(7) = "July" strMonthName(8) = "August" strMonthName(9) = "September" strMonthName(10) = "October" strMonthName(11) = "November" strMonthName(12) = "December" Case "EnShrt" ' أسماء الأشهر الإنجليزية المختصرة strMonthName(1) = "Jan" strMonthName(2) = "Feb" strMonthName(3) = "Mar" strMonthName(4) = "Apr" strMonthName(5) = "May" strMonthName(6) = "Jun" strMonthName(7) = "Jul" strMonthName(8) = "Aug" strMonthName(9) = "Sep" strMonthName(10) = "Oct" strMonthName(11) = "Nov" strMonthName(12) = "Dec" Case "Cpti" ' أسماء الأشهر القبطية strMonthName(1) = "Thout" strMonthName(2) = "Paope" strMonthName(3) = "Hator" strMonthName(4) = "Kiahk" strMonthName(5) = "Tobi" strMonthName(6) = "Meshir" strMonthName(7) = "Paremhat" strMonthName(8) = "Paremhou" strMonthName(9) = "Pashons" strMonthName(10) = "Paoni" strMonthName(11) = "Epip" strMonthName(12) = "Nasi" Case "Syr" ' أسماء الأشهر السريانية strMonthName(1) = "Nisan" strMonthName(2) = "Iyar" strMonthName(3) = "Sivan" strMonthName(4) = "Tammuz" strMonthName(5) = "Ab" strMonthName(6) = "Elul" strMonthName(7) = "Tishri" strMonthName(8) = "Heshvan" strMonthName(9) = "Kislev" strMonthName(10) = "Tevet" strMonthName(11) = "Shevat" strMonthName(12) = "Adar" Case "No" ' أسماء الأشهر بالأرقام strMonthName(1) = "( 01 )" strMonthName(2) = "( 02 )" strMonthName(3) = "( 03 )" strMonthName(4) = "( 04 )" strMonthName(5) = "( 05 )" strMonthName(6) = "( 06 )" strMonthName(7) = "( 07 )" strMonthName(8) = "( 08 )" strMonthName(9) = "( 09 )" strMonthName(10) = "( 10 )" strMonthName(11) = "( 11 )" strMonthName(12) = "( 12 )" End Select ' إرجاع اسم الشهر للتاريخ المحدد GetMonthName = strMonthName(Month(dtDate)) Else ' إرجاع سلسلة فارغة إذا كان التاريخ غير صالح GetMonthName = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '5 Public Function GetDayName(ByVal dtAnyDate As Date, ByVal strLng As String) As String ' الغرض: إرجاع اسم اليوم بناءً على التاريخ واللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج اسم اليوم منه. ' strLng - نوع اللغة لاسم اليوم: ' "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة. ' الإرجاع: اسم اليوم باللغة المحددة. ' ' مثال الاستخدام: ' txtDayNameAR = DayName(txtDate, "Ar") ' اسم اليوم بالعربية ' txtDayNameEn = DayName(txtDate, "En") ' اسم اليوم بالإنجليزية ' txtDayNameEnShrt = DayName(txtDate, "EnShrt") ' اسم اليوم بالإنجليزية المختصرة Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetDayName = "تاريخ غير صالح" Exit Function End If ' التحقق من صحة اللغة المحددة If strLng <> "Ar" And strLng <> "En" And strLng <> "EnShrt" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'Ar'، 'En'، أو 'EnShrt'.", vbExclamation, "خطأ" Exit Function End If ' تحديد أسماء الأيام بناءً على اللغة Select Case strLng Case "Ar" strSat = "السبت" strSun = "الأحد" strMon = "الاثنين" strTues = "الثلاثاء" strWed = "الأربعاء" strThurs = "الخميس" strFri = "الجمعة" Case "En" strSat = "Saturday" strSun = "Sunday" strMon = "Monday" strTues = "Tuesday" strWed = "Wednesday" strThurs = "Thursday" strFri = "Friday" Case "EnShrt" strSat = "Sat" strSun = "Sun" strMon = "Mon" strTues = "Tue" strWed = "Wed" strThurs = "Thu" strFri = "Fri" End Select ' إرجاع اسم اليوم بناءً على يوم الأسبوع للتاريخ المحدد GetDayName = Choose(Weekday(dtAnyDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function '----------------------------End------------------------------------------------------------------------------------------- '6 Public Function NumofDays(ByVal dtAnyDate As Date) As Integer ' الغرض: إرجاع عدد الأيام في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج عدد الأيام في شهره. ' الإرجاع: عدد الأيام في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtNumofDaysMonth = NumofDays(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial ' ثم إرجاع جزء اليوم من ذلك التاريخ، والذي يمثل العدد الإجمالي للأيام في ذلك الشهر. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" NumofDays = -1 ' إرجاع قيمة غير صالحة للإشارة إلى خطأ Exit Function End If NumofDays = Day(DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0)) End Function '----------------------------End------------------------------------------------------------------------------------------- '7 Public Function GetLastDayInMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayInMonth = GetLastDayInMonth(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial. ' تقوم هذه الدالة بإنشاء تاريخ مع السنة والشهر من التاريخ المحدد وتعيين اليوم إلى 0، ' مما يعطينا بشكل فعال آخر يوم في الشهر السابق، أي آخر يوم في الشهر الحالي. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayInMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If GetLastDayInMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '8 Public Function GetFirstDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في شهره. ' الإرجاع: أول يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfMonth = GetFirstDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' حساب أول يوم في الشهر الحالي باستخدام الدالة DateSerial GetFirstDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '9 Public Function GetFirstDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر التالي له. ' الإرجاع: أول يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfNextMonth = GetFirstDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر التالي باستخدام الدالة DateSerial GetFirstDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '10 Public Function GetFirstDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر السابق له. ' الإرجاع: أول يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfPreviousMonth = GetFirstDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر السابق باستخدام الدالة DateSerial GetFirstDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) - 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '11 Public Function GetLastDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfMonth = GetLastDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر باستخدام الدالة DateSerial GetLastDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '12 Public Function GetLastDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر التالي له. ' الإرجاع: آخر يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfNextMonth = GetLastDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر التالي باستخدام الدالة DateSerial GetLastDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 2, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '13 Public Function GetLastDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر السابق له. ' الإرجاع: آخر يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfPreviousMonth = GetLastDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر السابق باستخدام الدالة DateSerial GetLastDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '14 Public Function TimeByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع الوقت بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ/الوقت الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = TimeByLanguage(txtDateTime, "Ar") ' الوقت بالعربية ' txtTimeEnglish = TimeByLanguage(txtDateTime, "En") ' الوقت بالإنجليزية ' التحقق من أن dtAnyDate تاريخ/وقت صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا/وقتًا صالحًا. يرجى إدخال تاريخ/وقت صحيح.", vbExclamation, "تاريخ/وقت غير صالح" TimeByLanguage = "تاريخ/وقت غير صالح" Exit Function End If ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت إلى العربية واستبدال AM/PM بالنصوص العربية TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة TimeByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '15 Public Function GetLocalizedTimeString(ByVal strLng As String) As String ' الغرض: إرجاع الوقت الحالي بتنسيق اللغة المحددة. ' الوسائط: strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت الحالي بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = GetLocalizedTimeString("Ar") ' الوقت الحالي بالعربية ' txtTimeEnglish = GetLocalizedTimeString("En") ' الوقت الحالي بالإنجليزية ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت الحالي إلى العربية واستبدال AM/PM بالنصوص العربية GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت الحالي إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة GetLocalizedTimeString = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '16 Public Function FormatDateByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع التاريخ بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق التاريخ ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: التاريخ بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtDateArabic = FormatDateByLanguage(txtDate, "Ar") ' التاريخ بالعربية ' txtDateEnglish = FormatDateByLanguage(txtDate, "En") ' التاريخ بالإنجليزية ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" FormatDateByLanguage = "تاريخ غير صالح" Exit Function End If ' تنسيق التاريخ بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل التاريخ إلى العربية وإضافة رمز "م" (لتحديد التقويم الميلادي) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "م ", "Ar") Case "En" ' تحويل التاريخ إلى الإنجليزية وإضافة رمز "هـ" (لتحديد التقويم الهجري) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "هـ ", "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة FormatDateByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetFirstDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع أول يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: أول يوم في السنة المحددة (1 يناير). ' ' مثال الاستخدام: ' txtFirstDayOfYear = GetFirstDayOfYear(2023) ' أول يوم في سنة 2023 ' txtFirstDayOfYear = GetFirstDayOfYear() ' أول يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع أول يوم في السنة (1 يناير) GetFirstDayOfYear = DateSerial(ReferenceYear, 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetLastDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع آخر يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: آخر يوم في السنة المحددة (31 ديسمبر). ' ' مثال الاستخدام: ' txtLastDayOfYear = GetLastDayOfYear(2023) ' آخر يوم في سنة 2023 ' txtLastDayOfYear = GetLastDayOfYear() ' آخر يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع آخر يوم في السنة (31 ديسمبر) GetLastDayOfYear = DateSerial(ReferenceYear, 12, 31) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب الفرق بين تاريخين (بالأيام، الأشهر، السنوات) Public Function GetDateDifferenceInDays(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأيام. GetDateDifferenceInDays = DateDiff("d", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInMonths(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأشهر. GetDateDifferenceInMonths = DateDiff("m", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInYears(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالسنوات. GetDateDifferenceInYears = DateDiff("yyyy", dtStartDate, dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' إضافة أو طرح أيام/أشهر/سنوات من تاريخ معين Public Function AddDaysToDate(ByVal dtDate As Date, ByVal intDays As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأيام من تاريخ معين. AddDaysToDate = DateAdd("d", intDays, dtDate) End Function Public Function AddMonthsToDate(ByVal dtDate As Date, ByVal intMonths As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأشهر من تاريخ معين. AddMonthsToDate = DateAdd("m", intMonths, dtDate) End Function Public Function AddYearsToDate(ByVal dtDate As Date, ByVal intYears As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من السنوات من تاريخ معين. AddYearsToDate = DateAdd("yyyy", intYears, dtDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' التحقق مما إذا كان تاريخ معين ضمن نطاق تاريخين Public Function IsDateInRange(ByVal dtDate As Date, ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Boolean ' الغرض: التحقق مما إذا كان تاريخ معين يقع بين تاريخين محددين. IsDateInRange = (dtDate >= dtStartDate And dtDate <= dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب العمر بناءً على تاريخ الميلاد Public Function CalculateAge(ByVal dtBirthDate As Date) As Integer ' الغرض: حساب العمر بالسنوات بناءً على تاريخ الميلاد. CalculateAge = DateDiff("yyyy", dtBirthDate, Now) If DateSerial(Year(Now), Month(dtBirthDate), Day(dtBirthDate)) > Now Then CalculateAge = CalculateAge - 1 End If End Function '----------------------------End------------------------------------------------------------------------------------------- ' تحديد عدد الأيام منذ تاريخ معين Public Function GetDaysSinceDate(ByVal dtStartDate As Date) As Integer ' الغرض: حساب عدد الأيام المنقضية منذ تاريخ معين. GetDaysSinceDate = DateDiff("d", dtStartDate, Now) End Function '----------------------------End-------------------------------------------------------------------------------------------

لا لم تحل لا فى الاصداؤ الاخير ولا اللى قبله

تحقق من هذه الجزئيه لانه معى للاسف يخفى لوحة مفاتيح اللغة الانجليزية فى الاعدادت هى موجوده ولكن لا تعمل ولا يكتب اى حروف انجليزية

ع العموم للتخلص نهائيا من هذه المشاكل قمت ببعض التعديلات تم عمل التالى ترتيب اللغات داخل مربع السرد مع ضمان ظهرها باللغة العربية بشكل صحيح بدون مشاكل الترميز و طبقا لترتيب ويندوز الابقاء فقط على اللغات العربيىة طبقا لرغبتك اذا المرفق الاول يجمع كل الافكار وكل الاكواد ليكون مرجعا شاملا اما هذا المرفق الاخيـر يختص بحل المشكلة الخاصة بالترميز ودعم اللغة العربية على وجه الخصوص arabic for non unicode programs.accdb

ممكن ازالتها من الكود ولكن انا قلت احاول اقدم الكود باكبر قدر ممكن من الشموليه ولذلك انا عملت النموذجين العربى والانجليزى انا عندى شغاله اهون وانا اخترت البحرين من نموذج الاكسس ودى النتيجة بعد الريستارت خلينى اغير الدوله وارجع لك تانى بعد الريستارت ههههههه طيب وشكرا ليك بجد ع الفكرة