ابو جودي

وفى هذا الرابط شرح الـ 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

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

قد تكون المشكلة ناتجة عن تأخر في تحديث الشاشة يمكنك إضافة الكود التالي في حدث On Load للنموذج لإجبار النموذج على التحديث: Me.Repaint

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

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

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

السلام عليكم ورحمة الله تعالى وبركاته بعد مرورى على موضوع استاذى الجليل واخى الحبيب الاستاذ @Foksh والموضوع هو فى هذه >---->> المشاركة من هنا طلبت منه العب شويه بعد الاطلاع والتجربه على افكاره النيره وتطبيقه الاكثر من رائع وبجد الاول فى عرض فكرته تقريبا ولكن لن يكون الأخير فنحن هنا وحتما ولابد أن نضع بصمتنا زعق لى وقالى اجرى العب بعيد ياض من هنا لحسن ارش ميه 😡 قلت اجى العب هنا لحالى ولوحدى - وظيفة المرفق هى : ضبط وتعديل اللغة المستخدمة في البرامج غير الموحدة ( language for non-Unicode programs ) بس خلاص واترككم واتمنى لكم تجربة ممتعه شيقة مع المرفق الذى يحتوى على نموذجين الاول بالعربى لمن يريد , والثانى بالانجليزية لمن يريد فى انتظار أرائكم يا سادة ونحن لا نقيد أحد بل نضع الافكار بأكبر قدر ممكن من المرونة التى يمكن الحصول عليها والتعامل على هذا الاساس الاكود المستخدمة للنموذج الانجليزى ' Define constant messages to be used in the program Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "Your project cannot run without changing the system locale to Arabic" ' Define API functions based on the VBA version #If VBA7 Then ' 64-bit version Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As LongPtr, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As LongPtr) As Long Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As LongPtr, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As LongPtr) As Long Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32" () As Long #Else ' 32-bit version Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As Long) As Long Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long #End If ' Constants for use with Windows API Private Const HKEY_LOCAL_MACHINE As Long = &H80000002 Private Const KEY_QUERY_VALUE As Long = &H1 Private Const KEY_WOW64_64KEY As Long = &H100 Private Const KEY_WOW64_32KEY As Long = &H200 Private Const REG_SZ As Long = 1 ' Define a custom type "country" to store country information Private Type country countryCode As String ' Country code (e.g., "EG") countryName As String ' Country name (e.g., "Egypt") fullCountryName As String ' Full country name (e.g., "Arab Republic of Egypt") localeName As String ' Locale name (e.g., "ar-EG") localeID As String ' Locale ID (e.g., "00000C01") code As String ' Country calling code (e.g., "20") nativeLanguage As String ' Native language with country (e.g., "Arabic (Egypt)") End Type ' Define an array to store country settings Private countries() As country ' Define a variable to store the current country settings Private countrySettings As country Private Sub SetCountryData(countryCode As String, countryName As String, fullCountryName As String, localeName As String, localeID As String, code As String, nativeLanguage As String) ' Define a variable of type "country" to store the current country data Dim currentCountry As country ' Assign data values to the currentCountry variable currentCountry.countryCode = countryCode ' Country code currentCountry.countryName = countryName ' Country name currentCountry.fullCountryName = fullCountryName ' Full country name currentCountry.localeName = localeName ' Locale name currentCountry.localeID = localeID ' Locale ID currentCountry.code = code ' Country calling code currentCountry.nativeLanguage = nativeLanguage ' Native language with country ' Increase the size of the "countries" array while preserving existing data (ReDim Preserve) ReDim Preserve countries(UBound(countries) + 1) ' Add the current country data to the array countries(UBound(countries)) = currentCountry End Sub ' Function to check the current system language Private Function IsSystemLanguage(ByVal targetLocaleName As String, ByVal targetLocaleID As String) As Boolean ' Define variables Dim wshShell As Object ' WScript.Shell object to access the system registry Dim currentLocaleName As String ' To store the current system LocaleName Dim currentLocaleID As String ' To store the current system LocaleID ' Create a WScript.Shell object Set wshShell = CreateObject("WScript.Shell") ' Temporarily ignore errors to avoid program stoppage if registry keys are missing On Error Resume Next ' Read the LocaleName value from the system registry currentLocaleName = wshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\LocaleName") ' Read the LocaleID value from the system registry currentLocaleID = wshShell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Language\Default") ' Re-enable normal error handling On Error GoTo 0 ' Compare the current LocaleName and LocaleID with the target values If currentLocaleName = targetLocaleName And currentLocaleID = targetLocaleID Then ' If the values match, return True IsSystemLanguage = True Else ' If the values do not match, return False IsSystemLanguage = False End If End Function Private Sub CheckSystemLanguage() ' Define variables Dim targetLocaleName As String ' To store the target LocaleName Dim targetLocaleID As String ' To store the target LocaleID Dim isLanguageMatch As Boolean ' To store the result of the language check ' Set the target values targetLocaleName = "en-US" ' Target language: English - United States targetLocaleID = "0409" ' Target language ID: English - United States ' Call the IsSystemLanguage function to check if the language matches isLanguageMatch = IsSystemLanguage(targetLocaleName, targetLocaleID) ' Display the result based on the function's return value If isLanguageMatch Then ' If the language matches, show a confirmation message MsgBox "The system language matches the target language: " & targetLocaleName, vbInformation, "Language Check" Else ' If the language does not match, show a warning message with details MsgBox "The system language does NOT match the target language: " & targetLocaleName & vbNewLine & _ "Current Locale Name: " & targetLocaleName & vbNewLine & _ "Current Locale ID: " & targetLocaleID, vbExclamation, "Language Check" End If End Sub Private Sub LogError(ByVal errorMessage As String) ' Temporarily ignore errors to avoid program stoppage if an error occurs during logging On Error Resume Next ' Define variables Dim fso As Object ' FileSystemObject to handle files Dim logFile As Object ' TextStream object to write data to the file Dim desktopPath As String ' Desktop path Dim logFilePath As String ' Full path to the error log file ' Get the desktop path using WScript.Shell desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") ' Define the full path to the error log file logFilePath = desktopPath & "\ChangeLanguageErrorLog.txt" ' Create a FileSystemObject to handle files Set fso = CreateObject("Scripting.FileSystemObject") ' Open the error log file for writing (8 means append, True means create the file if it doesn't exist) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' Write the error message and timestamp to the file logFile.WriteLine "Error: " & errorMessage & vbCrLf & "Timestamp: " & Now ' Close the file after writing logFile.Close ' Re-enable normal error handling On Error GoTo 0 End Sub Private Sub ChangeSystemLanguage(Optional restartDelay As Integer = 15) ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Define variables Dim fso As Object ' FileSystemObject to handle files Dim batFile As Object ' TextStream object to write the batch file Dim logFile As Object ' TextStream object to write the log file Dim desktopPath As String ' Desktop path Dim batFilePath As String ' Full path to the batch file Dim logFilePath As String ' Full path to the log file Dim newLanguage As String ' New language (not used in the current code) Dim countryCode As String ' Country code Dim localeID As String ' Locale ID Dim localeName As String ' Locale name Dim countryName As String ' Country name ' Get the details of the selected country countryCode = countrySettings.countryCode localeID = countrySettings.localeID localeName = countrySettings.localeName countryName = countrySettings.countryName ' Get the desktop path desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") batFilePath = desktopPath & "\ChangeLanguage.bat" logFilePath = desktopPath & "\ChangeLanguageLog.txt" ' Create a FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' Create the batch file Set batFile = fso.CreateTextFile(batFilePath, True) ' Open the log file for appending Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' Write commands to the batch file With batFile .WriteLine "@echo off" ' Disable command display in the command window .WriteLine "chcp 1256" ' Change the code page to 1256 (for Arabic support) .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & localeName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & countryName & " /f" .WriteLine "shutdown /r /f /t " & restartDelay ' Restart the computer after a specified delay .Close ' Close the batch file End With ' Execute the batch file to change the language and restart Shell batFilePath, vbNormalFocus ' Notify the user about the language change and restart MsgBox "Language change is in progress. Your computer will restart in " & restartDelay & " seconds.", vbInformation, "Changing Language" ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Log the error in the log file LogError "Error in ChangeSystemLanguage: " & Err.Description ' Show an error message to the user MsgBox "An error occurred while changing the system language.", vbCritical End Sub Private Function IsArabicLanguage() As Boolean ' Define a variable to store the current system code page Dim CodePage As Long ' Get the current code page using the GetACP function CodePage = GetACP() ' Check if the code page is 1256 (Arabic) IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As country ' Search for the country in the array based on the country code Dim i As Integer For i = 0 To UBound(countries) If UCase(countries(i).countryName) = UCase(countryCode) Then ' If the country is found, return its details GetArabicCountrySettings = countries(i) Exit Function End If Next i ' If the country is not found, return Saudi Arabia as the default GetArabicCountrySettings = countries(4) ' Saudi Arabia End Function Sub LoadCountries() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Initialize the size of the countries array ReDim countries(0) ' Add country data to the array using the SetCountryData function ' Arabic Countries SetCountryData "AE", "UAE", "United Arab Emirates", "ar-AE", "00003801", "971", "Arabic (UAE)" SetCountryData "BH", "Bahrain", "Bahrain", "ar-BH", "00003C01", "973", "Arabic (Bahrain)" SetCountryData "DZ", "Algeria", "Algeria", "ar-DZ", "00001401", "213", "Arabic (Algeria)" SetCountryData "EG", "Egypt", "Egypt", "ar-EG", "00000C01", "20", "Arabic (Egypt)" SetCountryData "IQ", "Iraq", "Iraq", "ar-IQ", "00000801", "964", "Arabic (Iraq)" SetCountryData "JO", "Jordan", "Jordan", "ar-JO", "00000409", "962", "Arabic (Jordan)" SetCountryData "KW", "Kuwait", "Kuwait", "ar-KW", "00003401", "965", "Arabic (Kuwait)" SetCountryData "LB", "Lebanon", "Lebanon", "ar-LB", "00003001", "961", "Arabic (Lebanon)" SetCountryData "LY", "Libya", "Libya", "ar-LY", "00001001", "218", "Arabic (Libya)" SetCountryData "MA", "Morocco", "Morocco", "ar-MA", "00001801", "212", "Arabic (Morocco)" SetCountryData "MR", "Mauritania", "Mauritania", "ar-MR", "00001801", "222", "Arabic (Mauritania)" SetCountryData "OM", "Oman", "Oman", "ar-OM", "00002001", "968", "Arabic (Oman)" SetCountryData "PS", "Palestine", "Palestine", "ar-PS", "00000401", "970", "Arabic (Palestine)" SetCountryData "QA", "Qatar", "Qatar", "ar-QA", "00004001", "974", "Arabic (Qatar)" SetCountryData "SA", "Saudi Arabia", "Saudi Arabia", "ar-SA", "00000401", "966", "Arabic (Saudi Arabia)" SetCountryData "SD", "Sudan", "Sudan", "ar-SD", "00002C01", "249", "Arabic (Sudan)" SetCountryData "SO", "Somalia", "Somalia", "ar-SO", "00000401", "252", "Arabic (Somalia)" SetCountryData "SY", "Syria", "Syria", "ar-SY", "00002801", "963", "Arabic (Syria)" SetCountryData "TN", "Tunisia", "Tunisia", "ar-TN", "00001C01", "216", "Arabic (Tunisia)" SetCountryData "YE", "Yemen", "Yemen", "ar-YE", "00002401", "967", "Arabic (Yemen)" ' Chinese Countries SetCountryData "CN", "China", "China", "zh-CN", "00000804", "86", "Chinese (China)" SetCountryData "TW", "Taiwan", "Taiwan", "zh-TW", "00000404", "886", "Chinese (Taiwan)" SetCountryData "HK", "Hong Kong", "Hong Kong", "zh-HK", "00000C04", "852", "Chinese (Hong Kong)" SetCountryData "SG", "Singapore", "Singapore", "zh-SG", "00001004", "65", "Chinese (Singapore)" ' English Countries SetCountryData "AU", "Australia", "Australia", "en-AU", "00000C09", "61", "English (Australia)" SetCountryData "CA", "Canada", "Canada", "en-CA", "00001009", "1", "English (Canada)" SetCountryData "GB", "UK", "United Kingdom", "en-GB", "00000809", "44", "English (UK)" SetCountryData "IE", "Ireland", "Ireland", "en-IE", "00001809", "353", "English (Ireland)" SetCountryData "IN", "India", "India", "en-IN", "00000409", "91", "English (India)" SetCountryData "NG", "Nigeria", "Nigeria", "en-NG", "00000409", "234", "English (Nigeria)" SetCountryData "NZ", "New Zealand", "New Zealand", "en-NZ", "00001409", "64", "English (New Zealand)" SetCountryData "PH", "Philippines", "Philippines", "en-PH", "00000409", "63", "English (Philippines)" SetCountryData "US", "USA", "United States of America", "en-US", "00000409", "1", "English (US)" SetCountryData "ZA", "South Africa", "South Africa", "en-ZA", "00000409", "27", "English (South Africa)" ' French Countries SetCountryData "BE", "Belgium", "Belgium", "fr-BE", "0000080C", "32", "French (Belgium)" SetCountryData "CA", "Canada", "Canada", "fr-CA", "00000C0C", "1", "French (Canada)" SetCountryData "CH", "Switzerland", "Switzerland", "fr-CH", "0000100C", "41", "French (Switzerland)" SetCountryData "FR", "France", "France", "fr-FR", "0000040C", "33", "French (France)" SetCountryData "LU", "Luxembourg", "Luxembourg", "fr-LU", "0000140C", "352", "French (Luxembourg)" SetCountryData "SN", "Senegal", "Senegal", "fr-SN", "0000040C", "221", "French (Senegal)" ' German Countries SetCountryData "AT", "Austria", "Austria", "de-AT", "00000407", "43", "German (Austria)" SetCountryData "CH", "Switzerland", "Switzerland", "de-CH", "00000807", "41", "German (Switzerland)" SetCountryData "DE", "Germany", "Germany", "de-DE", "00000407", "49", "German (Germany)" SetCountryData "LI", "Liechtenstein", "Liechtenstein", "de-LI", "00001007", "423", "German (Liechtenstein)" ' Hindi Countries SetCountryData "IN", "India", "India", "hi-IN", "00000439", "91", "Hindi (India)" ' Indonesian Countries SetCountryData "ID", "Indonesia", "Indonesia", "id-ID", "00000421", "62", "Indonesian (Indonesia)" ' Italian Countries SetCountryData "IT", "Italy", "Italy", "it-IT", "00000410", "39", "Italian (Italy)" SetCountryData "SM", "San Marino", "San Marino", "it-SM", "00000410", "378", "Italian (San Marino)" SetCountryData "VA", "Vatican City", "Vatican City", "it-VA", "00000410", "379", "Italian (Vatican City)" ' Japanese Countries SetCountryData "JP", "Japan", "Japan", "ja-JP", "00000411", "81", "Japanese (Japan)" ' Korean Countries SetCountryData "KR", "South Korea", "South Korea", "ko-KR", "00000412", "82", "Korean (South Korea)" SetCountryData "KP", "North Korea", "North Korea", "ko-KP", "00000412", "850", "Korean (North Korea)" ' Portuguese Countries SetCountryData "BR", "Brazil", "Brazil", "pt-BR", "00000416", "55", "Portuguese (Brazil)" SetCountryData "PT", "Portugal", "Portugal", "pt-PT", "00000816", "351", "Portuguese (Portugal)" SetCountryData "AO", "Angola", "Angola", "pt-AO", "00000416", "244", "Portuguese (Angola)" SetCountryData "MZ", "Mozambique", "Mozambique", "pt-MZ", "00000416", "258", "Portuguese (Mozambique)" ' Russian Countries SetCountryData "RU", "Russia", "Russia", "ru-RU", "00000419", "7", "Russian (Russia)" SetCountryData "BY", "Belarus", "Belarus", "ru-BY", "00000419", "375", "Russian (Belarus)" SetCountryData "KZ", "Kazakhstan", "Kazakhstan", "ru-KZ", "00000419", "7", "Russian (Kazakhstan)" SetCountryData "KG", "Kyrgyzstan", "Kyrgyzstan", "ru-KG", "00000419", "996", "Russian (Kyrgyzstan)" ' Spanish Countries SetCountryData "AR", "Argentina", "Argentina", "es-AR", "00002C0A", "54", "Spanish (Argentina)" SetCountryData "BO", "Bolivia", "Bolivia", "es-BO", "00002C0A", "591", "Spanish (Bolivia)" SetCountryData "CL", "Chile", "Chile", "es-CL", "00002C0A", "56", "Spanish (Chile)" SetCountryData "CO", "Colombia", "Colombia", "es-CO", "00002C0A", "57", "Spanish (Colombia)" SetCountryData "CR", "Costa Rica", "Costa Rica", "es-CR", "00002C0A", "506", "Spanish (Costa Rica)" SetCountryData "CU", "Cuba", "Cuba", "es-CU", "00002C0A", "53", "Spanish (Cuba)" SetCountryData "DO", "Dominican Republic", "Dominican Republic", "es-DO", "00002C0A", "1", "Spanish (Dominican Republic)" SetCountryData "EC", "Ecuador", "Ecuador", "es-EC", "00002C0A", "593", "Spanish (Ecuador)" SetCountryData "ES", "Spain", "Spain", "es-ES", "0000040A", "34", "Spanish (Spain)" SetCountryData "GT", "Guatemala", "Guatemala", "es-GT", "00002C0A", "502", "Spanish (Guatemala)" SetCountryData "HN", "Honduras", "Honduras", "es-HN", "00002C0A", "504", "Spanish (Honduras)" SetCountryData "MX", "Mexico", "Mexico", "es-MX", "0000080A", "52", "Spanish (Mexico)" SetCountryData "NI", "Nicaragua", "Nicaragua", "es-NI", "00002C0A", "505", "Spanish (Nicaragua)" SetCountryData "PA", "Panama", "Panama", "es-PA", "00002C0A", "507", "Spanish (Panama)" SetCountryData "PE", "Peru", "Peru", "es-PE", "00002C0A", "51", "Spanish (Peru)" SetCountryData "PR", "Puerto Rico", "Puerto Rico", "es-PR", "00002C0A", "1", "Spanish (Puerto Rico)" SetCountryData "PY", "Paraguay", "Paraguay", "es-PY", "00002C0A", "595", "Spanish (Paraguay)" SetCountryData "SV", "El Salvador", "El Salvador", "es-SV", "00002C0A", "503", "Spanish (El Salvador)" SetCountryData "UY", "Uruguay", "Uruguay", "es-UY", "00002C0A", "598", "Spanish (Uruguay)" SetCountryData "VE", "Venezuela", "Venezuela", "es-VE", "00002C0A", "58", "Spanish (Venezuela)" ' Turkish Countries SetCountryData "TR", "Turkey", "Turkey", "tr-TR", "0000041F", "90", "Turkish (Turkey)" SetCountryData "CY", "Cyprus", "Cyprus", "tr-CY", "0000041F", "357", "Turkish (Cyprus)" ' Check if the cmbLanguage control exists in the form If Not Me.cmbLanguage Is Nothing Then ' Clear old items from the combo box Me.cmbLanguage = "" ' Populate the combo box with full country names from the array Dim i As Integer For i = 1 To UBound(countries) Me.cmbLanguage.AddItem countries(i).nativeLanguage Next i Else ' Show an error message if the combo box is not found MsgBox "The combo box 'cmbLanguage' could not be found.", vbCritical End If ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Log the error using the LogError function LogError "Error in LoadCountries: " & Err.Description ' Show an error message to the user MsgBox "An error occurred while loading countries.", vbCritical End Sub Private Sub Form_Load() ' Load country names into the combo box LoadCountries ' Set the default language (Egypt) in the combo box cmbLanguage.Value = "Arabic (Egypt)" ' Set the default country details (Egypt) countrySettings = GetArabicCountrySettings("EG") ' Display the country name in the text box txtConteryName.Value = GetNonUnicodeLanguage() End Sub Private Sub cmbLanguage_Change() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Get the selected country name from the combo box Dim selectedCountryName As String selectedCountryName = Me.cmbLanguage.Value ' Search for the selected country in the array Dim i As Integer For i = 1 To UBound(countries) If countries(i).nativeLanguage = selectedCountryName Then ' If the country is found, save its details countrySettings = countries(i) Exit For End If Next i ' Display a message based on the search result If i <= UBound(countries) Then MsgBox "Selected language: " & selectedCountryName, vbInformation, "Language Selected" Else MsgBox "The language was not found in the list.", vbExclamation, "Error" End If ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Show an error message if a problem occurs MsgBox "An error occurred while selecting the language.", vbCritical, "Error" End Sub Private Sub btnLanguage_Click() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Check if a language has been selected from the list If countrySettings.countryCode = "" Then MsgBox "Please select a language from the list.", vbExclamation, "Language Selection" Exit Sub End If ' Execute the language change with a 15-second delay before restarting Call ChangeSystemLanguage(15) ' Notify the user that the language change will occur and the system will restart soon MsgBox "The language has been successfully selected. The system will restart in 15 seconds.", vbInformation, "Language Change" ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Show an error message if a problem occurs MsgBox "An error occurred while attempting to change the language.", vbCritical, "Error" End Sub Private Function GetRegistryValue(ByVal keyPath As String, ByVal valueName As String) As String #If VBA7 Then ' 64-bit version Dim hKey As LongPtr #Else ' 32-bit version Dim hKey As Long #End If Dim ret As Long Dim valueType As Long Dim valueData As String Dim dataLength As Long ' Open the registry key ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, keyPath, 0, KEY_QUERY_VALUE Or KEY_WOW64_64KEY, hKey) If ret = 0 Then ' Determine the data size ret = RegQueryValueEx(hKey, valueName, 0, valueType, vbNullString, dataLength) If ret = 0 And valueType = REG_SZ Then ' Read the data valueData = String(dataLength, Chr(0)) ret = RegQueryValueEx(hKey, valueName, 0, valueType, valueData, dataLength) If ret = 0 Then ' Remove trailing null characters GetRegistryValue = Left(valueData, dataLength - 1) End If End If ' Close the registry key RegCloseKey (hKey) End If End Function Private Function GetNonUnicodeLanguage() As String Dim localeID As String ' Read the registry value localeID = GetRegistryValue("SYSTEM\CurrentControlSet\Control\Nls\Language", "Default") ' Convert the value to Long Dim localeIDLong As Long localeIDLong = Val("&H" & localeID) ' Use Locale ID to determine the language Select Case localeIDLong ' Arabic Countries Case &H401: GetNonUnicodeLanguage = "Arabic (Saudi Arabia)" Case &H801: GetNonUnicodeLanguage = "Arabic (Iraq)" Case &HC01: GetNonUnicodeLanguage = "Arabic (Egypt)" Case &H1001: GetNonUnicodeLanguage = "Arabic (Libya)" Case &H1401: GetNonUnicodeLanguage = "Arabic (Algeria)" Case &H1801: GetNonUnicodeLanguage = "Arabic (Morocco)" Case &H1C01: GetNonUnicodeLanguage = "Arabic (Tunisia)" Case &H2001: GetNonUnicodeLanguage = "Arabic (Oman)" Case &H2401: GetNonUnicodeLanguage = "Arabic (Yemen)" Case &H2801: GetNonUnicodeLanguage = "Arabic (Syria)" Case &H2C01: GetNonUnicodeLanguage = "Arabic (Jordan)" Case &H3001: GetNonUnicodeLanguage = "Arabic (Lebanon)" Case &H3401: GetNonUnicodeLanguage = "Arabic (Kuwait)" Case &H3801: GetNonUnicodeLanguage = "Arabic (UAE)" Case &H3C01: GetNonUnicodeLanguage = "Arabic (Bahrain)" Case &H4001: GetNonUnicodeLanguage = "Arabic (Qatar)" ' English Countries Case &H409: GetNonUnicodeLanguage = "English (United States)" Case &H809: GetNonUnicodeLanguage = "English (United Kingdom)" Case &HC09: GetNonUnicodeLanguage = "English (Australia)" Case &H1009: GetNonUnicodeLanguage = "English (Canada)" Case &H1409: GetNonUnicodeLanguage = "English (New Zealand)" Case &H1809: GetNonUnicodeLanguage = "English (Ireland)" Case &H1C09: GetNonUnicodeLanguage = "English (South Africa)" Case &H2009: GetNonUnicodeLanguage = "English (Jamaica)" Case &H2409: GetNonUnicodeLanguage = "English (Caribbean)" Case &H2809: GetNonUnicodeLanguage = "English (Belize)" Case &H2C09: GetNonUnicodeLanguage = "English (Trinidad)" Case &H3009: GetNonUnicodeLanguage = "English (Zimbabwe)" Case &H3409: GetNonUnicodeLanguage = "English (Philippines)" Case &H3809: GetNonUnicodeLanguage = "English (India)" ' French Countries Case &H40C: GetNonUnicodeLanguage = "French (France)" Case &H80C: GetNonUnicodeLanguage = "French (Belgium)" Case &HC0C: GetNonUnicodeLanguage = "French (Canada)" Case &H100C: GetNonUnicodeLanguage = "French (Switzerland)" Case &H140C: GetNonUnicodeLanguage = "French (Luxembourg)" Case &H180C: GetNonUnicodeLanguage = "French (Monaco)" Case &H1C0C: GetNonUnicodeLanguage = "French (Senegal)" ' German Countries Case &H407: GetNonUnicodeLanguage = "German (Germany)" Case &H807: GetNonUnicodeLanguage = "German (Switzerland)" Case &HC07: GetNonUnicodeLanguage = "German (Austria)" Case &H1007: GetNonUnicodeLanguage = "German (Liechtenstein)" ' Hindi Countries Case &H439: GetNonUnicodeLanguage = "Hindi (India)" ' Indonesian Countries Case &H421: GetNonUnicodeLanguage = "Indonesian (Indonesia)" ' Italian Countries Case &H410: GetNonUnicodeLanguage = "Italian (Italy)" Case &H810: GetNonUnicodeLanguage = "Italian (Switzerland)" Case &HC10: GetNonUnicodeLanguage = "Italian (San Marino)" Case &H1010: GetNonUnicodeLanguage = "Italian (Vatican City)" ' Japanese Countries Case &H411: GetNonUnicodeLanguage = "Japanese (Japan)" ' Korean Countries Case &H412: GetNonUnicodeLanguage = "Korean (South Korea)" Case &H812: GetNonUnicodeLanguage = "Korean (North Korea)" ' Portuguese Countries Case &H416: GetNonUnicodeLanguage = "Portuguese (Brazil)" Case &H816: GetNonUnicodeLanguage = "Portuguese (Portugal)" Case &HC16: GetNonUnicodeLanguage = "Portuguese (Angola)" Case &H1016: GetNonUnicodeLanguage = "Portuguese (Mozambique)" ' Russian Countries Case &H419: GetNonUnicodeLanguage = "Russian (Russia)" Case &H819: GetNonUnicodeLanguage = "Russian (Belarus)" Case &HC19: GetNonUnicodeLanguage = "Russian (Kazakhstan)" Case &H1019: GetNonUnicodeLanguage = "Russian (Kyrgyzstan)" ' Spanish Countries Case &H40A: GetNonUnicodeLanguage = "Spanish (Spain)" Case &H80A: GetNonUnicodeLanguage = "Spanish (Mexico)" Case &HC0A: GetNonUnicodeLanguage = "Spanish (Argentina)" Case &H100A: GetNonUnicodeLanguage = "Spanish (Colombia)" Case &H140A: GetNonUnicodeLanguage = "Spanish (Peru)" Case &H180A: GetNonUnicodeLanguage = "Spanish (Venezuela)" Case &H1C0A: GetNonUnicodeLanguage = "Spanish (Chile)" Case &H200A: GetNonUnicodeLanguage = "Spanish (Ecuador)" Case &H240A: GetNonUnicodeLanguage = "Spanish (Guatemala)" Case &H280A: GetNonUnicodeLanguage = "Spanish (Cuba)" Case &H2C0A: GetNonUnicodeLanguage = "Spanish (Bolivia)" Case &H300A: GetNonUnicodeLanguage = "Spanish (Dominican Republic)" Case &H340A: GetNonUnicodeLanguage = "Spanish (Puerto Rico)" Case &H380A: GetNonUnicodeLanguage = "Spanish (Uruguay)" Case &H3C0A: GetNonUnicodeLanguage = "Spanish (Paraguay)" Case &H400A: GetNonUnicodeLanguage = "Spanish (Costa Rica)" Case &H440A: GetNonUnicodeLanguage = "Spanish (El Salvador)" Case &H480A: GetNonUnicodeLanguage = "Spanish (Honduras)" Case &H4C0A: GetNonUnicodeLanguage = "Spanish (Nicaragua)" Case &H500A: GetNonUnicodeLanguage = "Spanish (Panama)" ' Turkish Countries Case &H41F: GetNonUnicodeLanguage = "Turkish (Turkey)" Case &H81F: GetNonUnicodeLanguage = "Turkish (Cyprus)" ' Default Case Case Else: GetNonUnicodeLanguage = "Unknown (Locale ID: " & localeID & ")" End Select End Function الاكواد المستخدمة فى النموذج العربى Option Compare Database Option Explicit ' تعريف الرسائل الثابتة التي سيتم استخدامها في البرنامج Private Const MSG_RESTART_SOON As String = "سيتم إعادة تشغيل الكمبيوتر خلال 15 ثانية" Private Const MSG_SAVE_FILES As String = "يرجى حفظ جميع الملفات المفتوحة" Private Const MSG_CANT_RUN As String = "لا يمكن تشغيل المشروع دون تغيير لغة النظام إلى العربية" ' تعريف الدوال API بناءً على إصدار VBA #If VBA7 Then ' إصدار 64 بت Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As LongPtr, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As LongPtr) As Long Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As LongPtr, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As LongPtr) As Long Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32" () As Long #Else ' إصدار 32 بت Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As Long) As Long Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long #End If ' ثوابت لاستخدامها مع Windows API Private Const HKEY_LOCAL_MACHINE As Long = &H80000002 Private Const KEY_QUERY_VALUE As Long = &H1 Private Const KEY_WOW64_64KEY As Long = &H100 Private Const KEY_WOW64_32KEY As Long = &H200 Private Const REG_SZ As Long = 1 ' تعريف نوع بيانات "country" لتخزين معلومات البلد Private Type country countryCode As String ' رمز البلد (مثال: "EG") countryName As String ' اسم البلد (مثال: "مصر") fullCountryName As String ' الاسم الكامل للبلد (مثال: "جمهورية مصر العربية") localeName As String ' اسم اللغة المحلية (مثال: "ar-EG") localeID As String ' معرف اللغة المحلية (مثال: "00000C01") code As String ' رمز الاتصال بالبلد (مثال: "20") nativeLanguage As String ' اللغة الأم مع البلد (مثال: "العربية (مصر)") End Type ' تعريف مصفوفة لتخزين إعدادات البلدان Private countries() As country ' تعريف متغير لتخزين إعدادات البلد الحالية Private countrySettings As country Private Sub LogError(ByVal errorMessage As String) ' تجاهل الأخطاء مؤقتًا لتجنب توقف البرنامج في حالة حدوث خطأ أثناء تسجيل الخطأ On Error Resume Next ' تعريف المتغيرات Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات Dim logFile As Object ' كائن TextStream لكتابة البيانات في الملف Dim desktopPath As String ' مسار سطح المكتب Dim logFilePath As String ' المسار الكامل لملف تسجيل الأخطاء ' الحصول على مسار سطح المكتب باستخدام WScript.Shell desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") ' تحديد المسار الكامل لملف تسجيل الأخطاء logFilePath = desktopPath & "\ChangeLanguageErrorLog.txt" ' إنشاء كائن FileSystemObject للتعامل مع الملفات Set fso = CreateObject("Scripting.FileSystemObject") ' فتح ملف تسجيل الأخطاء للكتابة (الرقم 8 يعني الإلحاق، True يعني إنشاء الملف إذا لم يكن موجودًا) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' كتابة رسالة الخطأ والطابع الزمني في الملف logFile.WriteLine "Error: " & errorMessage & vbCrLf & "Timestamp: " & Now ' إغلاق الملف بعد الانتهاء من الكتابة logFile.Close ' إعادة تفعيل معالجة الأخطاء العادية On Error GoTo 0 End Sub Private Sub SetCountryData(countryCode As String, countryName As String, fullCountryName As String, localeName As String, localeID As String, code As String, nativeLanguage As String) ' تعريف متغير من النوع "country" لتخزين بيانات البلد الحالي Dim currentCountry As country ' تعيين قيم البيانات إلى المتغير currentCountry currentCountry.countryCode = countryCode ' رمز البلد currentCountry.countryName = countryName ' اسم البلد currentCountry.fullCountryName = fullCountryName ' الاسم الكامل للبلد currentCountry.localeName = localeName ' اسم اللغة المحلية currentCountry.localeID = localeID ' معرف اللغة المحلية currentCountry.code = code ' رمز الاتصال بالبلد currentCountry.nativeLanguage = nativeLanguage ' اللغة الأم مع البلد ' زيادة حجم المصفوفة "countries" مع الاحتفاظ بالبيانات الموجودة (ReDim Preserve) ReDim Preserve countries(UBound(countries) + 1) ' إضافة بيانات البلد الحالي إلى المصفوفة countries(UBound(countries)) = currentCountry End Sub ' دالة للتحقق من لغة النظام الحالية Private Function IsSystemLanguage(ByVal targetLocaleName As String, ByVal targetLocaleID As String) As Boolean ' تعريف المتغيرات Dim wshShell As Object ' كائن WScript.Shell للوصول إلى سجل النظام Dim currentLocaleName As String ' لتخزين LocaleName الحالي للنظام Dim currentLocaleID As String ' لتخزين LocaleID الحالي للنظام ' إنشاء كائن WScript.Shell Set wshShell = CreateObject("WScript.Shell") ' تجاهل الأخطاء مؤقتًا لتجنب توقف البرنامج في حالة عدم وجود مفاتيح السجل On Error Resume Next ' قراءة قيمة LocaleName من سجل النظام currentLocaleName = wshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\LocaleName") ' قراءة قيمة LocaleID من سجل النظام currentLocaleID = wshShell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Language\Default") ' إعادة تفعيل معالجة الأخطاء العادية On Error GoTo 0 ' مقارنة LocaleName و LocaleID الحاليين مع القيم المستهدفة If currentLocaleName = targetLocaleName And currentLocaleID = targetLocaleID Then ' إذا كانت القيم متطابقة، يتم إرجاع True IsSystemLanguage = True Else ' إذا كانت القيم غير متطابقة، يتم إرجاع False IsSystemLanguage = False End If End Function Private Sub CheckSystemLanguage() ' تعريف المتغيرات Dim targetLocaleName As String ' لتخزين LocaleName المستهدف Dim targetLocaleID As String ' لتخزين LocaleID المستهدف Dim isLanguageMatch As Boolean ' لتخزين نتيجة التحقق من تطابق اللغة ' تحديد القيم المستهدفة targetLocaleName = "en-US" ' اللغة المستهدفة: الإنجليزية - الولايات المتحدة targetLocaleID = "0409" ' معرف اللغة المستهدف: الإنجليزية - الولايات المتحدة ' استدعاء الدالة IsSystemLanguage للتحقق من تطابق اللغة isLanguageMatch = IsSystemLanguage(targetLocaleName, targetLocaleID) ' عرض النتيجة بناءً على ما تعيده الدالة If isLanguageMatch Then ' إذا كانت اللغة مطابقة، يتم عرض رسالة تأكيد MsgBox "لغة النظام مطابقة للغة المستهدفة: " & targetLocaleName, vbInformation, "التحقق من اللغة" Else ' إذا كانت اللغة غير مطابقة، يتم عرض رسالة تحذير مع تفاصيل MsgBox "لغة النظام غير مطابقة للغة المستهدفة: " & targetLocaleName & vbNewLine & _ "اللغة الحالية: " & targetLocaleName & vbNewLine & _ "معرف اللغة الحالي: " & targetLocaleID, vbExclamation, "التحقق من اللغة" End If End Sub Private Sub ChangeSystemLanguage(Optional restartDelay As Integer = 15) ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' تعريف المتغيرات Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات Dim batFile As Object ' كائن TextStream لكتابة ملف الباتش Dim logFile As Object ' كائن TextStream لكتابة ملف السجل Dim desktopPath As String ' مسار سطح المكتب Dim batFilePath As String ' المسار الكامل لملف الباتش Dim logFilePath As String ' المسار الكامل لملف السجل Dim newLanguage As String ' اللغة الجديدة (غير مستخدمة في الكود الحالي) Dim countryCode As String ' رمز البلد Dim localeID As String ' معرف اللغة المحلية Dim localeName As String ' اسم اللغة المحلية Dim countryName As String ' اسم البلد ' الحصول على تفاصيل البلد المحدد countryCode = countrySettings.countryCode localeID = countrySettings.localeID localeName = countrySettings.localeName countryName = countrySettings.countryName ' الحصول على مسار سطح المكتب desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") batFilePath = desktopPath & "\ChangeLanguage.bat" logFilePath = desktopPath & "\ChangeLanguageLog.txt" ' إنشاء كائن FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' إنشاء ملف الباتش Set batFile = fso.CreateTextFile(batFilePath, True) ' فتح ملف السجل للإلحاق (Append) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' كتابة الأوامر في ملف الباتش With batFile .WriteLine "@echo off" ' إيقاف عرض الأوامر في نافذة الأوامر .WriteLine "chcp 1256" ' تغيير صفحة الترميز إلى 1256 (للدعم العربي) .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & localeName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & countryName & " /f" .WriteLine "shutdown /r /f /t " & restartDelay ' إعادة تشغيل الكمبيوتر بعد تأخير محدد .Close ' إغلاق ملف الباتش End With ' تنفيذ ملف الباتش لتغيير اللغة وإعادة التشغيل Shell batFilePath, vbNormalFocus ' إعلام المستخدم بتغيير اللغة وإعادة التشغيل MsgBox "جاري تغيير اللغة. سيتم إعادة تشغيل الكمبيوتر خلال " & restartDelay & " ثانية.", vbInformation, "تغيير اللغة" ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' تسجيل الخطأ في ملف السجل LogError "حدث خطأ في ChangeSystemLanguage: " & Err.Description ' إظهار رسالة خطأ للمستخدم MsgBox "حدث خطأ أثناء محاولة تغيير لغة النظام.", vbCritical End Sub Private Function IsArabicLanguage() As Boolean ' تعريف المتغير لتخزين صفحة الترميز الحالية للنظام Dim CodePage As Long ' الحصول على صفحة الترميز الحالية باستخدام الدالة GetACP CodePage = GetACP() ' التحقق مما إذا كانت صفحة الترميز هي 1256 (العربية) IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As country ' البحث عن البلد في المصفوفة بناءً على رمز البلد Dim i As Integer For i = 0 To UBound(countries) If UCase(countries(i).countryName) = UCase(countryCode) Then ' إذا تم العثور على البلد، يتم إرجاع تفاصيله GetArabicCountrySettings = countries(i) Exit Function End If Next i ' إذا لم يتم العثور على البلد، يتم إرجاع السعودية كإعداد افتراضي GetArabicCountrySettings = countries(4) ' السعودية End Function Sub LoadCountries() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' تهيئة الحجم الأولي للمصفوفة countries ReDim countries(0) ' إضافة بيانات البلدان إلى المصفوفة باستخدام الدالة SetCountryData ' البلدان العربية SetCountryData "AE", "UAE", "الإمارات العربية المتحدة", "ar-AE", "00003801", "971", "العربية (الإمارات)" SetCountryData "BH", "Bahrain", "البحرين", "ar-BH", "00003C01", "973", "العربية (البحرين)" SetCountryData "DZ", "Algeria", "الجزائر", "ar-DZ", "00001401", "213", "العربية (الجزائر)" SetCountryData "EG", "Egypt", "مصر", "ar-EG", "00000C01", "20", "العربية (مصر)" SetCountryData "IQ", "Iraq", "العراق", "ar-IQ", "00000801", "964", "العربية (العراق)" SetCountryData "JO", "Jordan", "الأردن", "ar-JO", "00000409", "962", "العربية (الأردن)" SetCountryData "KW", "Kuwait", "الكويت", "ar-KW", "00003401", "965", "العربية (الكويت)" SetCountryData "LB", "Lebanon", "لبنان", "ar-LB", "00003001", "961", "العربية (لبنان)" SetCountryData "LY", "Libya", "ليبيا", "ar-LY", "00001001", "218", "العربية (ليبيا)" SetCountryData "MA", "Morocco", "المغرب", "ar-MA", "00001801", "212", "العربية (المغرب)" SetCountryData "MR", "Mauritania", "موريتانيا", "ar-MR", "00001801", "222", "العربية (موريتانيا)" SetCountryData "OM", "Oman", "عُمان", "ar-OM", "00002001", "968", "العربية (عُمان)" SetCountryData "PS", "Palestine", "فلسطين", "ar-PS", "00000401", "970", "العربية (فلسطين)" SetCountryData "QA", "Qatar", "قطر", "ar-QA", "00004001", "974", "العربية (قطر)" SetCountryData "SA", "Saudi Arabia", "المملكة العربية السعودية", "ar-SA", "00000401", "966", "العربية (السعودية)" SetCountryData "SD", "Sudan", "السودان", "ar-SD", "00002C01", "249", "العربية (السودان)" SetCountryData "SO", "Somalia", "الصومال", "ar-SO", "00000401", "252", "العربية (الصومال)" SetCountryData "SY", "Syria", "سوريا", "ar-SY", "00002801", "963", "العربية (سوريا)" SetCountryData "TN", "Tunisia", "تونس", "ar-TN", "00001C01", "216", "العربية (تونس)" SetCountryData "YE", "Yemen", "اليمن", "ar-YE", "00002401", "967", "العربية (اليمن)" ' البلدان الصينية SetCountryData "CN", "China", "الصين", "zh-CN", "00000804", "86", "الصينية (الصين)" SetCountryData "TW", "Taiwan", "تايوان", "zh-TW", "00000404", "886", "الصينية (تايوان)" SetCountryData "HK", "Hong Kong", "هونغ كونغ", "zh-HK", "00000C04", "852", "الصينية (هونغ كونغ)" SetCountryData "SG", "Singapore", "سنغافورة", "zh-SG", "00001004", "65", "الصينية (سنغافورة)" ' البلدان الإنجليزية SetCountryData "AU", "Australia", "أستراليا", "en-AU", "00000C09", "61", "الإنجليزية (أستراليا)" SetCountryData "CA", "Canada", "كندا", "en-CA", "00001009", "1", "الإنجليزية (كندا)" SetCountryData "GB", "UK", "المملكة المتحدة", "en-GB", "00000809", "44", "الإنجليزية (المملكة المتحدة)" SetCountryData "IE", "Ireland", "أيرلندا", "en-IE", "00001809", "353", "الإنجليزية (أيرلندا)" SetCountryData "IN", "India", "الهند", "en-IN", "00000409", "91", "الإنجليزية (الهند)" SetCountryData "NG", "Nigeria", "نيجيريا", "en-NG", "00000409", "234", "الإنجليزية (نيجيريا)" SetCountryData "NZ", "New Zealand", "نيوزيلندا", "en-NZ", "00001409", "64", "الإنجليزية (نيوزيلندا)" SetCountryData "PH", "Philippines", "الفلبين", "en-PH", "00000409", "63", "الإنجليزية (الفلبين)" SetCountryData "US", "USA", "الولايات المتحدة الأمريكية", "en-US", "00000409", "1", "الإنجليزية (الولايات المتحدة)" SetCountryData "ZA", "South Africa", "جنوب أفريقيا", "en-ZA", "00000409", "27", "الإنجليزية (جنوب أفريقيا)" ' البلدان الفرنسية SetCountryData "BE", "Belgium", "بلجيكا", "fr-BE", "0000080C", "32", "الفرنسية (بلجيكا)" SetCountryData "CA", "Canada", "كندا", "fr-CA", "00000C0C", "1", "الفرنسية (كندا)" SetCountryData "CH", "Switzerland", "سويسرا", "fr-CH", "0000100C", "41", "الفرنسية (سويسرا)" SetCountryData "FR", "France", "فرنسا", "fr-FR", "0000040C", "33", "الفرنسية (فرنسا)" SetCountryData "LU", "Luxembourg", "لوكسمبورغ", "fr-LU", "0000140C", "352", "الفرنسية (لوكسمبورغ)" SetCountryData "SN", "Senegal", "السنغال", "fr-SN", "0000040C", "221", "الفرنسية (السنغال)" ' البلدان الألمانية SetCountryData "AT", "Austria", "النمسا", "de-AT", "00000407", "43", "الألمانية (النمسا)" SetCountryData "CH", "Switzerland", "سويسرا", "de-CH", "00000807", "41", "الألمانية (سويسرا)" SetCountryData "DE", "Germany", "ألمانيا", "de-DE", "00000407", "49", "الألمانية (ألمانيا)" SetCountryData "LI", "Liechtenstein", "ليختنشتاين", "de-LI", "00001007", "423", "الألمانية (ليختنشتاين)" ' البلدان الهندية SetCountryData "IN", "India", "الهند", "hi-IN", "00000439", "91", "الهندية (الهند)" ' البلدان الإندونيسية SetCountryData "ID", "Indonesia", "إندونيسيا", "id-ID", "00000421", "62", "الإندونيسية (إندونيسيا)" ' البلدان الإيطالية SetCountryData "IT", "Italy", "إيطاليا", "it-IT", "00000410", "39", "الإيطالية (إيطاليا)" SetCountryData "SM", "San Marino", "سان مارينو", "it-SM", "00000410", "378", "الإيطالية (سان مارينو)" SetCountryData "VA", "Vatican City", "الفاتيكان", "it-VA", "00000410", "379", "الإيطالية (الفاتيكان)" ' البلدان اليابانية SetCountryData "JP", "Japan", "اليابان", "ja-JP", "00000411", "81", "اليابانية (اليابان)" ' البلدان الكورية SetCountryData "KR", "South Korea", "كوريا الجنوبية", "ko-KR", "00000412", "82", "الكورية (كوريا الجنوبية)" SetCountryData "KP", "North Korea", "كوريا الشمالية", "ko-KP", "00000412", "850", "الكورية (كوريا الشمالية)" ' البلدان البرتغالية SetCountryData "BR", "Brazil", "البرازيل", "pt-BR", "00000416", "55", "البرتغالية (البرازيل)" SetCountryData "PT", "Portugal", "البرتغال", "pt-PT", "00000816", "351", "البرتغالية (البرتغال)" SetCountryData "AO", "Angola", "أنغولا", "pt-AO", "00000416", "244", "البرتغالية (أنغولا)" SetCountryData "MZ", "Mozambique", "موزمبيق", "pt-MZ", "00000416", "258", "البرتغالية (موزمبيق)" ' البلدان الروسية SetCountryData "RU", "Russia", "روسيا", "ru-RU", "00000419", "7", "الروسية (روسيا)" SetCountryData "BY", "Belarus", "بيلاروسيا", "ru-BY", "00000419", "375", "الروسية (بيلاروسيا)" SetCountryData "KZ", "Kazakhstan", "كازاخستان", "ru-KZ", "00000419", "7", "الروسية (كازاخستان)" SetCountryData "KG", "Kyrgyzstan", "قيرغيزستان", "ru-KG", "00000419", "996", "الروسية (قيرغيزستان)" ' البلدان الإسبانية SetCountryData "AR", "Argentina", "الأرجنتين", "es-AR", "00002C0A", "54", "الإسبانية (الأرجنتين)" SetCountryData "BO", "Bolivia", "بوليفيا", "es-BO", "00002C0A", "591", "الإسبانية (بوليفيا)" SetCountryData "CL", "Chile", "تشيلي", "es-CL", "00002C0A", "56", "الإسبانية (تشيلي)" SetCountryData "CO", "Colombia", "كولومبيا", "es-CO", "00002C0A", "57", "الإسبانية (كولومبيا)" SetCountryData "CR", "Costa Rica", "كوستاريكا", "es-CR", "00002C0A", "506", "الإسبانية (كوستاريكا)" SetCountryData "CU", "Cuba", "كوبا", "es-CU", "00002C0A", "53", "الإسبانية (كوبا)" SetCountryData "DO", "Dominican Republic", "جمهورية الدومينيكان", "es-DO", "00002C0A", "1", "الإسبانية (جمهورية الدومينيكان)" SetCountryData "EC", "Ecuador", "الإكوادور", "es-EC", "00002C0A", "593", "الإسبانية (الإكوادور)" SetCountryData "ES", "Spain", "إسبانيا", "es-ES", "0000040A", "34", "الإسبانية (إسبانيا)" SetCountryData "GT", "Guatemala", "غواتيمالا", "es-GT", "00002C0A", "502", "الإسبانية (غواتيمالا)" SetCountryData "HN", "Honduras", "هندوراس", "es-HN", "00002C0A", "504", "الإسبانية (هندوراس)" SetCountryData "MX", "Mexico", "المكسيك", "es-MX", "0000080A", "52", "الإسبانية (المكسيك)" SetCountryData "NI", "Nicaragua", "نيكاراغوا", "es-NI", "00002C0A", "505", "الإسبانية (نيكاراغوا)" SetCountryData "PA", "Panama", "بنما", "es-PA", "00002C0A", "507", "الإسبانية (بنما)" SetCountryData "PE", "Peru", "بيرو", "es-PE", "00002C0A", "51", "الإسبانية (بيرو)" SetCountryData "PR", "Puerto Rico", "بورتوريكو", "es-PR", "00002C0A", "1", "الإسبانية (بورتوريكو)" SetCountryData "PY", "Paraguay", "باراغواي", "es-PY", "00002C0A", "595", "الإسبانية (باراغواي)" SetCountryData "SV", "El Salvador", "السلفادور", "es-SV", "00002C0A", "503", "الإسبانية (السلفادور)" SetCountryData "UY", "Uruguay", "أوروغواي", "es-UY", "00002C0A", "598", "الإسبانية (أوروغواي)" SetCountryData "VE", "Venezuela", "فنزويلا", "es-VE", "00002C0A", "58", "الإسبانية (فنزويلا)" ' البلدان التركية SetCountryData "TR", "Turkey", "تركيا", "tr-TR", "0000041F", "90", "التركية (تركيا)" SetCountryData "CY", "Cyprus", "قبرص", "tr-CY", "0000041F", "357", "التركية (قبرص)" ' التحقق من وجود عنصر cmbLanguage في النموذج If Not Me.cmbLanguage Is Nothing Then ' مسح العناصر القديمة من مربع السرد Me.cmbLanguage = "" ' ملء مربع السرد بأسماء البلدان الكاملة من المصفوفة Dim i As Integer For i = 1 To UBound(countries) Me.cmbLanguage.AddItem countries(i).nativeLanguage Next i Else ' إظهار رسالة خطأ إذا لم يتم العثور على مربع السرد MsgBox "لا يمكن العثور على مربع السرد 'cmbLanguage'.", vbCritical End If ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' تسجيل الخطأ في ملف السجل باستخدام الدالة LogError LogError "حدث خطأ في LoadCountries: " & Err.Description ' إظهار رسالة خطأ للمستخدم MsgBox "حدث خطأ أثناء تحميل البلدان", vbCritical End Sub Private Sub Form_Load() ' تحميل أسماء البلدان إلى مربع السرد LoadCountries ' تعيين اللغة الافتراضية (مصر) في مربع السرد cmbLanguage.Value = "العربية (مصر)" ' تعيين تفاصيل البلد الافتراضي (مصر) countrySettings = GetArabicCountrySettings("EG") ' عرض اسم البلد في مربع النص txtConteryName.Value = GetNonUnicodeLanguage() End Sub Private Sub cmbLanguage_Change() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' الحصول على اسم البلد المختار من مربع السرد Dim selectedCountryName As String selectedCountryName = Me.cmbLanguage.Value ' البحث عن البلد المختار في المصفوفة Dim i As Integer For i = 1 To UBound(countries) If countries(i).nativeLanguage = selectedCountryName Then ' إذا تم العثور على البلد، يتم حفظ تفاصيله countrySettings = countries(i) Exit For End If Next i ' إظهار رسالة بناءً على نتيجة البحث If i <= UBound(countries) Then MsgBox "تم تحديد اللغة: " & selectedCountryName, vbInformation, "لغة مختارة" Else MsgBox "لم يتم العثور على اللغة في القائمة.", vbExclamation, "خطأ" End If ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' إظهار رسالة خطأ في حالة حدوث مشكلة MsgBox "حدث خطأ أثناء تحديد اللغة.", vbCritical, "خطأ" End Sub Private Sub btnLanguage_Click() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' التحقق مما إذا تم اختيار لغة من القائمة If countrySettings.countryCode = "" Then MsgBox "يرجى اختيار لغة من القائمة.", vbExclamation, "اختيار اللغة" Exit Sub End If ' تنفيذ تغيير اللغة مع تأخير 15 ثانية قبل إعادة التشغيل Call ChangeSystemLanguage(15) ' إعلام المستخدم بأن تغيير اللغة سيتم وإعادة التشغيل قريبًا MsgBox "تم تحديد اللغة بنجاح، سيتم إعادة تشغيل النظام في غضون 15 ثانية.", vbInformation, "تغيير اللغة" ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' إظهار رسالة خطأ في حالة حدوث مشكلة MsgBox "حدث خطأ أثناء محاولة تغيير اللغة.", vbCritical, "خطأ" End Sub Private Function GetRegistryValue(ByVal keyPath As String, ByVal valueName As String) As String #If VBA7 Then ' إصدار 64 بت Dim hKey As LongPtr #Else ' إصدار 32 بت Dim hKey As Long #End If Dim ret As Long Dim valueType As Long Dim valueData As String Dim dataLength As Long ' فتح المفتاح ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, keyPath, 0, KEY_QUERY_VALUE Or KEY_WOW64_64KEY, hKey) If ret = 0 Then ' تحديد حجم البيانات ret = RegQueryValueEx(hKey, valueName, 0, valueType, vbNullString, dataLength) If ret = 0 And valueType = REG_SZ Then ' قراءة البيانات valueData = String(dataLength, Chr(0)) ret = RegQueryValueEx(hKey, valueName, 0, valueType, valueData, dataLength) If ret = 0 Then ' إزالة الأحرف الفارغة من النهاية GetRegistryValue = Left(valueData, dataLength - 1) End If End If ' إغلاق المفتاح RegCloseKey (hKey) End If End Function Private Function GetNonUnicodeLanguage() As String Dim localeID As String ' قراءة قيمة السجل localeID = GetRegistryValue("SYSTEM\CurrentControlSet\Control\Nls\Language", "Default") ' تحويل القيمة إلى Long Dim localeIDLong As Long localeIDLong = Val("&H" & localeID) ' استخدام Locale ID لتحديد اللغة Select Case localeIDLong ' البلدان العربية Case &H401: GetNonUnicodeLanguage = "العربية (السعودية)" Case &H801: GetNonUnicodeLanguage = "العربية (العراق)" Case &HC01: GetNonUnicodeLanguage = "العربية (مصر)" Case &H1001: GetNonUnicodeLanguage = "العربية (ليبيا)" Case &H1401: GetNonUnicodeLanguage = "العربية (الجزائر)" Case &H1801: GetNonUnicodeLanguage = "العربية (المغرب)" Case &H1C01: GetNonUnicodeLanguage = "العربية (تونس)" Case &H2001: GetNonUnicodeLanguage = "العربية (عُمان)" Case &H2401: GetNonUnicodeLanguage = "العربية (اليمن)" Case &H2801: GetNonUnicodeLanguage = "العربية (سوريا)" Case &H2C01: GetNonUnicodeLanguage = "العربية (الأردن)" Case &H3001: GetNonUnicodeLanguage = "العربية (لبنان)" Case &H3401: GetNonUnicodeLanguage = "العربية (الكويت)" Case &H3801: GetNonUnicodeLanguage = "العربية (الإمارات)" Case &H3C01: GetNonUnicodeLanguage = "العربية (البحرين)" Case &H4001: GetNonUnicodeLanguage = "العربية (قطر)" ' البلدان الإنجليزية Case &H409: GetNonUnicodeLanguage = "الإنجليزية (الولايات المتحدة)" Case &H809: GetNonUnicodeLanguage = "الإنجليزية (المملكة المتحدة)" Case &HC09: GetNonUnicodeLanguage = "الإنجليزية (أستراليا)" Case &H1009: GetNonUnicodeLanguage = "الإنجليزية (كندا)" Case &H1409: GetNonUnicodeLanguage = "الإنجليزية (نيوزيلندا)" Case &H1809: GetNonUnicodeLanguage = "الإنجليزية (أيرلندا)" Case &H1C09: GetNonUnicodeLanguage = "الإنجليزية (جنوب أفريقيا)" Case &H2009: GetNonUnicodeLanguage = "الإنجليزية (جامايكا)" Case &H2409: GetNonUnicodeLanguage = "الإنجليزية (الكاريبي)" Case &H2809: GetNonUnicodeLanguage = "الإنجليزية (بليز)" Case &H2C09: GetNonUnicodeLanguage = "الإنجليزية (ترينيداد)" Case &H3009: GetNonUnicodeLanguage = "الإنجليزية (زيمبابوي)" Case &H3409: GetNonUnicodeLanguage = "الإنجليزية (الفلبين)" Case &H3809: GetNonUnicodeLanguage = "الإنجليزية (الهند)" ' البلدان الفرنسية Case &H40C: GetNonUnicodeLanguage = "الفرنسية (فرنسا)" Case &H80C: GetNonUnicodeLanguage = "الفرنسية (بلجيكا)" Case &HC0C: GetNonUnicodeLanguage = "الفرنسية (كندا)" Case &H100C: GetNonUnicodeLanguage = "الفرنسية (سويسرا)" Case &H140C: GetNonUnicodeLanguage = "الفرنسية (لوكسمبورغ)" Case &H180C: GetNonUnicodeLanguage = "الفرنسية (موناكو)" Case &H1C0C: GetNonUnicodeLanguage = "الفرنسية (السنغال)" ' البلدان الألمانية Case &H407: GetNonUnicodeLanguage = "الألمانية (ألمانيا)" Case &H807: GetNonUnicodeLanguage = "الألمانية (سويسرا)" Case &HC07: GetNonUnicodeLanguage = "الألمانية (النمسا)" Case &H1007: GetNonUnicodeLanguage = "الألمانية (ليختنشتاين)" ' البلدان الهندية Case &H439: GetNonUnicodeLanguage = "الهندية (الهند)" ' البلدان الإندونيسية Case &H421: GetNonUnicodeLanguage = "الإندونيسية (إندونيسيا)" ' البلدان الإيطالية Case &H410: GetNonUnicodeLanguage = "الإيطالية (إيطاليا)" Case &H810: GetNonUnicodeLanguage = "الإيطالية (سويسرا)" Case &HC10: GetNonUnicodeLanguage = "الإيطالية (سان مارينو)" Case &H1010: GetNonUnicodeLanguage = "الإيطالية (الفاتيكان)" ' البلدان اليابانية Case &H411: GetNonUnicodeLanguage = "اليابانية (اليابان)" ' البلدان الكورية Case &H412: GetNonUnicodeLanguage = "الكورية (كوريا الجنوبية)" Case &H812: GetNonUnicodeLanguage = "الكورية (كوريا الشمالية)" ' البلدان البرتغالية Case &H416: GetNonUnicodeLanguage = "البرتغالية (البرازيل)" Case &H816: GetNonUnicodeLanguage = "البرتغالية (البرتغال)" Case &HC16: GetNonUnicodeLanguage = "البرتغالية (أنغولا)" Case &H1016: GetNonUnicodeLanguage = "البرتغالية (موزمبيق)" ' البلدان الروسية Case &H419: GetNonUnicodeLanguage = "الروسية (روسيا)" Case &H819: GetNonUnicodeLanguage = "الروسية (بيلاروسيا)" Case &HC19: GetNonUnicodeLanguage = "الروسية (كازاخستان)" Case &H1019: GetNonUnicodeLanguage = "الروسية (قيرغيزستان)" ' البلدان الإسبانية Case &H40A: GetNonUnicodeLanguage = "الإسبانية (إسبانيا)" Case &H80A: GetNonUnicodeLanguage = "الإسبانية (المكسيك)" Case &HC0A: GetNonUnicodeLanguage = "الإسبانية (الأرجنتين)" Case &H100A: GetNonUnicodeLanguage = "الإسبانية (كولومبيا)" Case &H140A: GetNonUnicodeLanguage = "الإسبانية (بيرو)" Case &H180A: GetNonUnicodeLanguage = "الإسبانية (فنزويلا)" Case &H1C0A: GetNonUnicodeLanguage = "الإسبانية (تشيلي)" Case &H200A: GetNonUnicodeLanguage = "الإسبانية (الإكوادور)" Case &H240A: GetNonUnicodeLanguage = "الإسبانية (غواتيمالا)" Case &H280A: GetNonUnicodeLanguage = "الإسبانية (كوبا)" Case &H2C0A: GetNonUnicodeLanguage = "الإسبانية (بوليفيا)" Case &H300A: GetNonUnicodeLanguage = "الإسبانية (جمهورية الدومينيكان)" Case &H340A: GetNonUnicodeLanguage = "الإسبانية (بورتوريكو)" Case &H380A: GetNonUnicodeLanguage = "الإسبانية (أوروغواي)" Case &H3C0A: GetNonUnicodeLanguage = "الإسبانية (باراغواي)" Case &H400A: GetNonUnicodeLanguage = "الإسبانية (كوستاريكا)" Case &H440A: GetNonUnicodeLanguage = "الإسبانية (السلفادور)" Case &H480A: GetNonUnicodeLanguage = "الإسبانية (هندوراس)" Case &H4C0A: GetNonUnicodeLanguage = "الإسبانية (نيكاراغوا)" Case &H500A: GetNonUnicodeLanguage = "الإسبانية (بنما)" ' البلدان التركية Case &H41F: GetNonUnicodeLanguage = "التركية (تركيا)" Case &H81F: GetNonUnicodeLanguage = "التركية (قبرص)" ' الحالة الافتراضية Case Else: GetNonUnicodeLanguage = "غير معروف (Locale ID: " & localeID & ")" End Select End Function بس خلاص واترككم فى حفظ الله ورعايته واتمنى لكم تجربة ممتعه شيقة مع المرفق الذى يحتوى على نموذجين طبعا لم اهتم كثيرا بالتفاصيل والرسائل بقدر اهتمامى باليه العمل الاول بالعربى لمن يريد , والثانى بالانجليزية لمن يريد فى انتظار أرائكم يا سادة ChangeLanguage V 1.0.zip

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

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

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

الله يسلمك شوف نظريا كده دى الاجابة اعمل وحدة نمطية جديدة فى قاعدة البيانات بتاعتك واعطها مثلا الاسم : basGeneratorPassword وضع بها الاكواد الاتية ... Public Const DefaultLength As Integer = 10 Public Const DefaultSpecialChars As String = "'?,./<>|\[]{}:;#$%&()*+-@_""" & "!`~@#$%^&*()=€¥»«©®™°¢£•÷׶" Public Function GeneratePassword( _ Optional Length As Integer = DefaultLength, _ Optional bNumeric As Boolean = True, _ Optional bUpperAlpha As Boolean = True, _ Optional bLowerAlpha As Boolean = True, _ Optional bSpecialChr As Boolean = True, _ Optional sSpecialChr As String = DefaultSpecialChars) As String On Error GoTo Error_Handler Dim AllowedChars() As Variant Dim iCounter As Integer Dim i As Integer Dim iRndChar As Integer Dim iNoAllowedChars As Long Dim sGeneratedPwd As String Const sModName = "modGeneratorPassword" ' Initialize array ReDim AllowedChars(0) ' Numeric If bNumeric Then For i = 48 To 57 ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) AllowedChars(UBound(AllowedChars)) = i Next i End If ' Uppercase Alphabet If bUpperAlpha Then For i = 65 To 90 ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) AllowedChars(UBound(AllowedChars)) = i Next i End If ' Lowercase Alphabet If bLowerAlpha Then For i = 97 To 122 ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) AllowedChars(UBound(AllowedChars)) = i Next i End If ' Special Characters If bSpecialChr And Trim(sSpecialChr) <> "" Then For i = 1 To Len(sSpecialChr) ReDim Preserve AllowedChars(UBound(AllowedChars) + 1) AllowedChars(UBound(AllowedChars)) = Asc(Mid$(sSpecialChr, i, 1)) Next i End If ' Generate Password Randomize iNoAllowedChars = UBound(AllowedChars) For i = 1 To DefaultLength iRndChar = Int((iNoAllowedChars - 1) * Rnd + 1) sGeneratedPwd = sGeneratedPwd & Replace(Chr(AllowedChars(iRndChar)), "'", "''") Next i GeneratePassword = sGeneratedPwd Error_Handler_Exit: On Error Resume Next Exit Function Error_Handler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: " & sModName & "/OfficenaGeneratePwd" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occurred!" Resume Error_Handler_Exit End Function الان انظر فى الحدث الذى تريد استدعاء الداله فيه وليكن مثلا بعد تحديث التاريخ حقل التاريخ ضع اسفل الاكواد التى استخدمتها هذه الاكواد If IsNull(Me.TextBoxNameOnForm) Or Me.TextBoxNameOnForm = "" Then Dim strRandomNumber As String strRandomNumber = GeneratePassword(8, True, True, True, False) Dim intRandomNumber As Integer intRandomNumber = DCount("FieldNameInTable", "TableName", "FieldNameInTable = '" & Replace(strRandomNumber, "'", "''") & "'") If intRandomNumber > 0 Then strRandomNumber = GeneratePassword(8, True, True, True, False) End If Me.TextBoxNameOnForm = strRandomNumber Else End If الان فقط غير فى كود الاستدعاء التالى : اسم مربع النص والذى تريد اظهار الرموز العشوائية بداخله و الموجود على النموذج بدلا من: Me.TextBoxNameOnForm وغير اسم الجدول بدلا من : TableName وغير اسم الحقل داخل الجدول والخاص بالرموز العشوائية بدلا من : FieldNameInTable وطبعا انا بدأت كود الاستدعاء بأسلوب يجعل الرموز العشوائية لكل سجل فريدة ولا تتكرر يمكنك اما ازالتها او تركها حسب حاجتك ملاحظة اضافيه ان اردت الرموز العشوائية تحتوى على رموز بجانب الارقام والاحرف الكبيرة والصغيرة فقط استدع الدالة بالشكل التالى strRandomNumber = GeneratePassword(8, True, True, True, True)

للاسف لن استطيع فتح او التعامل مع اى قواعد بيانات فى الوقت الراهن بس ان شاء الله ابشر