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

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

السلام علبكم 🙂 بسبب اختلاف تنسيقات ملفات الاكسل (او CSV) ، وخصوصا تلك التي من مواقع وزارة التعليم في المملكة العربية السعودية ، كنا نضطر ان نتعامل بالكود مع كل تنسيق بطريقة تختلف عن الملف الآخر ، مما يجعل الحل لا يتناسب مع التنسيقات الملفات الاخرى ، وهذا الكود ليس بالسهل تعديله. ولكن ، تقريبا جميع مستخدمي الاكسس يعرفون التعامل مع الاستعلام ، لهذا السبب دعونا نتعامل مع بيانات الاكسل في استعلام ، استعلام مسقط 🙂 هذه واجهة النموذج الذي يتم كل شيء عن طريقه: 1. لتصفح الملفات ، واختيار ملف الاكسل (xls, xlsx, xlsm, csv) ، وسيظهر اسم الملف الذي تم اختيارة في الحقل رقم 2 ، 3. ستظهر قائمة بأسماء الاوراق (Sheets) الموجودة في الملف ، ويجب اختيار الورقة المطلوبة ، 4. هذا نموذج جدولي ، و ستظهر بيانات ورقة الاكسل هنا ، ويمكننا التعامل مع فرز وتصفية البيانات هنا ، وبعدة طرق ، 5. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 6. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبدون أسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 7. يجب النقر هنا حتى نرى نتائج الفرز والتصفية كجزء من الاستعلام في الحقول 8 و 9 ، 8. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 9. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 10. يمكنك عمل استعلام جاهز (للورقة بدون فرز وتصفية) او جدول ، سواء في قاعدة البيانات هذه ، او اختيار قاعدة بيانات خارجية (يجب ان تكون مغلقة حتى تستطيع تصدير استعلام او جدول لها) ، وسيكون اسم الاستعلام نفس اسم الورقة ، مثلا اسم الورقة ABC ، فيصبح اسم الاستعلام: qry_ABC ، او يكون جدول بإسم tbl_ABC حسب اختيارك من الرقم 11 ، او حتى الحاق بيانات الاستعلام الى جدول موجود سابقا (طبعا يجب مراعاة ان يكون الجدول بنفس حقول الورقة) ، 12. لنسخ الاستعلام الى ذاكرة الكمبيوتر ، بحيث يمكنك استعمال لصق ctrl+v لكائن الاستعلام (انظ الفيديو التوضيحي) ، 13. عادة لا نغير اي شيء هنا. طريقة العمل: . نرى من اعلاه: 1. انه تم عمل استعلام ياسم qry_Sheet1 في قاعدة البيانات الخارجة Testing.accdb ، 2. كذلك نسخنا استعلام التصفة الى ذاكرة الكمبيوتر (تابع في الفيديو التالي) . ممكن خلط عمل الفرز و التصفية بعدة طرق ، منها كما في الفيديو اعلاه ، و الصور التاليه . . لنفتح قاعدة البيانات الخارجية ونرى ما فيها ، هنا نحن نتعامل مع استعلام اكسس عادي ، فيمكننا حذف الحقول التي لا نريدها ، او نخفي اخرى ، او .... . عند فتح قاعدة البيانات الخارجية ، وحصلت على رسالة الخطأ هذه ، فهذا معناه ان برنامج "استعلام مسقط" لايزال مفتوح ، وملف الاكسل مفتوح به ، لذا يجب اغلاق برنامج "استعلام مسقط" قبل استعمال ملف الاكسل : . البرنامج يتعامل مع ملف واحد فقط ، ويعمل له استعلام ، واذا اردنا ان نتعامل مع اكثر من ورقة اكسل ، فيمكننا عمل مجموعة من استعلامات ، ثم نعمل امر لتنفيذها واحدة تلو الاخرى ، وبما انه عندنا استعلام ، فيمكننا تحويله الى جميع انواع الاستعلامات ، سواء استعلام الحاق ، او استعلام اضافة ، او استعلام لعمل جدول. هناك عدة ميزات في استعمال هذه الطريقة عن ربط الاكسل كجدول : 1. اسرع بكثير ، 2. عند استيراد كائنات قاعدة البيانات الى قاعدة اخرى ، فالاكسس يتوقف كثيرا عند الجداول الاكسل المرتبطة ، بينما لا يأخذ اي وقت لهذا الاستعلام 3. اختار الحقول اللي تريدها فقط ، جعفر Muscat_Query.zip

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم فكرة مبتكرة لتصميم :: الصفحة الرئيسية للبرنامج مع قائمة جانبية متمددة :: بألوان جميلة وتصميم راقي وتحكم شامل بعدد عناصر القائمة والقوائم الفرعية لها 👌 وأهم شي استهلاك أقل كمية من البرمجة والأكواد في التصميم ✌ :: وبدون مقدمات نبدأ على بركة الله :: الفكرة الرئيسة للقائمة الجانبية هي : عمل نموذج فرعي مستمر يستمد بياناته من جدول بحيث أن جميع عناصر القائمة الفرعية عبارة عن سجلات هذا الجدول ، ومن خلال هذا الجدول يتم ترتيب مواقع العناصر من خلال الحقل الرقم Order وكذلك يتم تصنيفها إن كانت زر رئيسي أم فرعي من خلال حقل Main or Sub والأيقونات يتم تخزينها في حقل مرفقات ، وأما الأوامر التي ستنفذها الأزرار فهي مخزنة أيضا في الجدول وهي محصورة في الأوامر التالية ( فتح نموذج - فتح نموذج فرعي - فتح تقرير - فتح تقرير فرعي - إظاهر رسالة نصية) .. والخطوة التي تأتي بعد ذالك هي تصميم النموذج الذي سيضم هذه الأزرار ، ويراعي الترتيب + فرز الأزرار الرئيسية والفرعية في الظهور + التنسيق الشرطي الذي يلون الأزرار بالألوان المناسبة لكل حالة + كود لتنفيذ الأوامر الموكلة للأزرار + .... وهكذا ثم بعد ذلك تصميم نموذج شامل للتحكم بالأزرار .. :: وللاستفادة من هذا الملف :: ستحتاج لهذه العناصر فقط ، ( والباقي كله زيادات لغرض الشرح ) : :: وهنا يأتي شرح يوتيوبي كافي وافي مفصل عن التصميم :: وفيه أيضا فوائد إضافية مثل ( طريقة اختيار أيقونات متناسقة ، وإشارة للنماذج المتطورة الأخرى ) :: تحديثات جديدة :: قمت بتطوير النموذج ليحمل أزرار فرعية وأزرار فرعية من الفرعية بناءا على طلب بعض الإخوة 🙂 كما تم إضافة خاصية إمكانية فتح الماكرو للأزرار .. وكذلك مع إمكانية فتح النماذج والتقارير في وضع التكبير Maximize .. وهذه لوحة التحكم : :: وأخيراا ملف التحميل 🙂 :: ‏‏‏‏Modern Main Page With Main Menue And Sub Sub Btns - Moosak -Maximize-Macro.accdb ملاحظة مهمة : قد لا يعمل هذا النموذج بشكل جيد على النسخ القديمة من 2007 وما قبلها . :: ولا تنسونا من صالح دعواتكم الطيبة 🙂 🌹🌷 ::

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكنها بالحديثة و بطريقة فوكشية ▫▪◽◾◻◼. الكثير من المواضيع التي تحدثت عن كيفية رفع ملفات المستخدم على جوجل درايف أو غيره من المواقع التي تقدم مساحات سحابية متعددة الخدمات لمستخدميها .. اليوم وبتوفيق من الله ، تم إنشاء هذه الأداة للتعامل مع جوجل درايف Google Driveحصراً ، لكونه يقدم مساحة 15 جيجا بايت لمستخدميه . ما كان يؤرق الكثيرين هو أن جوجل أو غيره من مقدمي الخدمة المشابهة يقوم بتعديل سياسته وقوانينه كل فترة . لكن هنا وبهذه الأداة المجانية تم حل المشكلة بعد فحصها مراراً وتكراراً (متمنياً ذلك) . الفكرة في الأداة تعتمد على حساب جوجل أو Gmail شخصي . ما يلزم المستخدم هنا تطبيق الخطوات البسيطة التالية حسب الصور أو الفيديو في هذا الرابط . 📌 عند فتح الأداة لأول مرة ، سيساعدك معالج الإنشاء بجميع الخطوات ( خطوة بخطوة ) وستظهر لك هذه الرسالة :- 📌 عند النقر على Yes ، ستظهر لك رسالة الإرشاد الأولى كالتالي :- 📌 سيتم فتح المتصفح لديك على الرابط الخاص بإنشاء الخدمة .. وللمتابعة دون الإطالة ، أترككم مع الصور و الخطوات خطوة بخطوة . 📌 عند الإنتهاء من تنفيذ الخطوات والحصول على رمزي الـ ( CLIENT ID و CLIENT SECRET ) . ✨ سيتوجه بك معالج الإنشاء للخطوة قبل الأخيرة كالآتي :- 📌 هنا يطلب منك لصق رمز CLIENT ID الذي حصلت عليه من تسلسل الخطوات السابقة . ثم بعد لصقه والضغط على OK ، ستظهر لك الرسالة التالية :- 📌 والتي يطلب منك لصق CLIENT SECRET كما في الصورة أعلاه . ✨ الآن الخطوة الهامة والتلقائية ، وبعد لصق الرمزين الخاصين بحسابك في جوجل درايف ( لا تقم بمشاركتهم مع أي أحد ) ، سنهب للحصول على رمز التفويض مرة واحدة فقط ! وهذا يعني أنك لن تحتاج إليه مستقبلاً . انظر الصورة التالية :- 📌 عند النقر على موافق ، سيتم فتح متصفحك على رابط خاص في جوجل لتمنح بريدك الإلكتروني الذي استخدمته في إنشاء الخدمة سابقاً كامل الصلاحية لإستخدام خدمات جوجل درايف . وطبعاً بالمتابعة وتأكيد الموافقة ، ستحصل على رمز التفويض الخاص بك و لمرة واحدة فقط ولن تحتاجه فيما بعد ، فتقوم بنسخه ولصقه في رسالة التأكيد التالية :- الآن وبفضل الله ، ستظهر لك رسالة " تم التفويض بنجاح" ، وبهذه الخطوة تم ربط آكسيس بحساب جوجل درايف الخاص بك ، وستظهر لك واجهة الأداة كما في الصورة أدناه . وما يلي شرحاً سريعاً لمميزاتها . مميزات الأداة :- تتيح لك الأداة رفع الملفات بأي امتداد وبأي حجم ؛ إلى أي مجلد تحدده في حسابك على جوجل درايف ، أو في الملف الرئيسي عند عدم اختيارك لمجلد محدد . والمجلدات التي في حسابك ستظهر لك عند النقر على زر "مجلداتي" ، ثم من قائمة الكومبوبوكس ستختار المجلد الهدف لرفع الملف اليه . زر "إختيار ملف" لإختيار الملف الذي ترغب برفعه على جوجل درايف . زر "معاينة" مخصص لمعاينة الملف حسب الرسالة التي ستظهر لك . زر "مسح الحقول" لتفريغ العناصر من قيمها . زر "ارفع الملف" والذي من خلاله ستقوم بتنفيذ عملية رفع الملف إلى حسابك في جوجل درايف . بعد إتمام عملية الرفع بنجاح ، يتم عرض المساحة المستخدمة من المساحة التخزينية لحسابك ( وهي 15 جيجا ) ، والنسبة المئوية للمساحة في عنوان النموذج ، كما في الصورة أدناه لعملية الرفع . زر "نسخ الرابط" لنسخ الرابط بعد أن تمت عملية الرفع بنجاح ( لإستخداماتك الشخصية وحاجتك لاحقاً ) . وفيما يلي ، صورة سريعة لعملية رفع صورة على سبيل المثال : ملف الأداة بنسختين .. نسخة 64 بت نسخة 32 بت Uploader.zip Uploader 32.zip

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

اعرض الملف 🎁📅 :: المخطط السنوي للإجازات :: 🌼🌷 :: عرض جميع إجازات الموظفين على الجدول الزمني Gantt Cart دايناميكي 😊👌🏻 السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم هذه الهدية المتواضعة :: المخطط السنوي للإجازات :: وهو عبارة عن تقويم سنوي لإجازات الموظفين يتم رسمه دايناميكيا على مخطط رسم بياني يسمى Gantt Chart 👌 يمتاز التصميم بالسهولة والجمال والإبداعية وقد شرحت كيفية استخدامه في الفيديو التالي ✌ في التحديث الجديد 1.7 تم إضافة حقل لمجموع عدد الأيام سنويا ... مع دعم للإجازات عابرات القارات (الإجازات التي تمتد لعدة سنوات كالإجازات الدراسية الطويلة) ظهور عدد الأيام في جميع النوافذ من مميزات هذا المخطط: - عرض جميع الإجازات في صفحة واحدة يسهل من قرائتها ومراجعتها. - تصميم رائع وألوان جميلة . - سهل الاستخدام . - وكذلك هذا المخطط يمكن استخدامه للمشاريع بدل الإجازات أو عرض مدة الإيجارات أو .. أو .. أو ... حيث لا حدود للإبداع 🙂 :: وأخيرا وليس آخرا :: :: لا تنسونا ووالدينا من صالح دعواتكم الطيبة 🙂 🌹🌷 :: صاحب الملف Moosak تمت الاضافه 01 ينا, 2025 الاقسام قسم الأكسيس

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) بالإشارة الى الموضوع الذي أعلنت عنه سابقاً في هذا الرابط هنا ، اسمحوا لي بأن أطرح هذه الفكرة الجديدة والتي تم تجربتها مراراً وتكراراً إلى أن خرجت بهذه النتيجة فيما يتعلق بموضوع التحديث الهوائي أو Online أو OTA ( Over-The-Air ) . الموضوع بداية بسيط جداً ولن يحتاج تعقيد في تنفيذ هذه الطريقة . حيث ما يلزمنا أولاً هو حساب على Google Drive ( لماذا ؟ = لأن 95 % من الأشخاص عندهم هذا الحساب ) . و حساب على موقع Dropbox ( لماذا ؟ = لأنه يعطينا امكانية التحميل برابط مباشر خلافاً في جوجل درايف ) وهو ما يميزه عن Google Drive . بناءً على ما سلف ، نبدأ شرح الخطوات والمتطلبات على بركة الله :- 1. سنحتاج جدول واحد مرفق وهو ( Settings ) ، ولا أنصح بالتلاعب به ما لم يكن على أساس صحيح ؛ ويحتوي على الحقول التالية :- الحقل Ver = رقمي = لتحديد الإصدار الحالي للنسخة الحالية في قاعدة البيانات الحالية. الحقل Link = نصي = لتحديد رابط الملف النصي الذي سيتم قراءة الإصدار الجديد منه ومقارنته مع قيمة الحقل Ver لتحديد ما اذا كان هناك نسخة جديدة أم لا . الحقل URLS = نصي = سيتم ادراج رابط التحميل للإصدار الجديد من خلال الكود تلقائياً. الحقل DBName = نصي = سيمكانك هنا من تحديد اسم قاعدة البيانات التي سيتم حفظ التحديث الجديد بها . وهنا لتسهيل فكرة اسم القاعدة القديمة واستبدالها بالنسخة الجديدة سيتم جلب القيمة تلقائياً . الحقل Auto_Check = نوع Yes/No = لتفعيل ميزة الفحص التلقائي للتحديثات ( فكرة شبيهة بتلك التي في أجهزة الجوال والمحمول عند تفعيلها يصلك إشعارك بوجود نسخة جديدة إن كانت الميزة مفعلة طبعاً ) 2. تحميل الإصدار الجديد على موقع Dropbox ونسخ رابط الملف ( مع التأكد أن الملف عند مشاركته قد تمت مشاركته للجميع - الموقع يجعلها قيمة افتراضية - ولكن للتأكيد ) . 3. ملف نصي واحد ( TxT. ) سميه ما شئت وهو ثابت غير قابل للتبديل ، ويكون محتواه ما يلي :- السطر الأول نضع رقم الإصدار الجديد . اي انه في الملف القديم لنفترض ان قيمة الحقل Ver = 0.1 . هنا في الملف النصي سنضع الإصدار الأحدث أي مثلاً ( 0.2 ). السطر الثاني نضع رابط النسخة الحديثة التي تم رفعها على Dropbox في النقطة السابقة 2 . أي انه سيكون لدينا ملف نصي يحتوي سطرين الأول رقم الإصدار الحديث والذي ستتم قراءته و مقارنته مع الحقل Ver في الإصدار الذي لدى العميل ، والسطر الثاني رابط النسخة الأحدث من دروب بوكس . 4. سنقوم برفع هذا الملف النصي على جوجل درايف ( السبب : دروب بوكس لم يدعم فكرة قراءة الملف النصي وجلب قيمة رقم الاصدار في السطر الأول لمقارنتها مع القيمة في النسخة التي لدى العميل في الحقل Ver ) . 5. ثم سنقوم بنسخ الرابط لهذا الملف النصي ومشاركته للجميع - أو بمعنى آخر لمن يملك الرابط - ولصقه في الجدول الثابت Settings في الحقل Link وهو هنا سيكون أيضاً قيمة ثابتة لن تتغير . أي أنك ستقوم بتغيير فقط رقم الإصدار في النسخة الجديدة في الحقل Ver . وإعادة رفع الملف النصي بعد تحديث قيمة رقم الاصدار الجديد فقط . طبعاً هنا بالإفتراض جدلاً وبعد تجربة متكررة أنه عندما تقوم برفع ملف موجود مسبقاً على أي موقع من ( جوجل درايف أو دروب بوكس ) فأن العنوان لهذا الملف لن يتغير لأنه سيتم استبدال الملف القديم بالجديد . ( وهي نقطة جيدة استفدنا منها لصالحنا ). 6. الآن الفكرة بشكل عام واضحة ولا تحتاج لتعقيد في الشرح ( وأي فكرة أو طريقة في البداية ستحتاج مرات معدودة لتصبح سهلة في تطبيقها عن ظهر قلب ) الآن وما هو مهم للجميع ، الكود التالي للمديول :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Public Function IsInternetConnected() As Boolean On Error GoTo ErrorHandler Dim xhr As Object Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", "https://www.google.com", False xhr.send IsInternetConnected = (xhr.Status = 200) Set xhr = Nothing Exit Function ErrorHandler: IsInternetConnected = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Public Function ConvertGoogleDriveLink(ByVal originalLink As String) As String On Error GoTo ErrorHandler Dim FileID As String If InStr(1, originalLink, "/d/") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "/d/") + 3) FileID = Left(FileID, InStr(1, FileID, "/") - 1) ElseIf InStr(1, originalLink, "id=") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "id=") + 3) If InStr(1, FileID, "&") > 0 Then FileID = Left(FileID, InStr(1, FileID, "&") - 1) End If End If If Len(FileID) > 0 Then ConvertGoogleDriveLink = "https://drive.google.com/uc?id=" & FileID Else ConvertGoogleDriveLink = originalLink End If Exit Function ErrorHandler: ConvertGoogleDriveLink = originalLink End Function Public Function CheckForUpdate() As Boolean On Error GoTo ErrorHandler Dim currentVer As Double Dim onlineVer As Double Dim xhr As Object Dim onlineContent As String Dim driveLink As String Dim contentLines() As String Dim updateURL As String Dim currentDBName As String currentDBName = CurrentDb.Name currentDBName = Mid(currentDBName, InStrRev(currentDBName, "\") + 1) currentDBName = Left(currentDBName, InStrRev(currentDBName, ".") - 1) CurrentDb.Execute "UPDATE Settings SET DBName = '" & Replace(currentDBName, "'", "''") & "'" currentVer = DLookup("Ver", "Settings") If Not IsInternetConnected() Then Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم الإصدار: " & currentVer CheckForUpdate = False Exit Function End If driveLink = ConvertGoogleDriveLink(DLookup("Link", "Settings")) Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", driveLink, False xhr.setRequestHeader "User-Agent", "Mozilla/5.0" xhr.send If xhr.ReadyState = 4 Then If xhr.Status = 200 Then onlineContent = Trim(xhr.responseText) contentLines = Split(onlineContent, vbCrLf) If UBound(contentLines) >= 1 Then onlineVer = Val(contentLines(0)) updateURL = Trim(contentLines(1)) If onlineVer > 0 Then If onlineVer > currentVer Then CurrentDb.Execute "UPDATE Settings SET URLS = '" & updateURL & "'" Forms!Frm_Index!Lbl_Load.Caption = " تحديث جديد متوفر الآن : " & onlineVer & " Ver - انقر للتحميل " Forms!Frm_Index!ImgUpdate.Visible = True CheckForUpdate = True Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus Else Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم أحدث إصدار : " & onlineVer & " Ver " Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus End If End If End If End If End If Set xhr = Nothing Exit Function ErrorHandler: CheckForUpdate = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Sub UpdateURLSAndOpenNewDatabase() Dim UrlValue As String, NameValue As String Dim TargetDb As DAO.Database Dim rs As DAO.Recordset Dim CurrentDbPath As String Dim NewDbPath As String CurrentDbPath = CurrentProject.Path & "\" & Dir(CurrentProject.FullName) NewDbPath = CurrentProject.Path & "\Data\Update.accdb" If Dir(CurrentProject.Path & "\Data\Update.Dll") <> "" Then Name CurrentProject.Path & "\Data\Update.Dll" As NewDbPath Else MsgBox "الملف Update.Dll غير موجود", vbCritical Exit Sub End If On Error GoTo ErrorHandler UrlValue = Nz(CurrentDb.OpenRecordset("SELECT URLS FROM Settings").Fields("URLS").Value, "") NameValue = Nz(CurrentDb.OpenRecordset("SELECT DBName FROM Settings").Fields("DBName").Value, "") If UrlValue = "" Or NameValue = "" Then MsgBox "خطأ في تحميل التحديث", vbCritical Exit Sub End If Set TargetDb = DBEngine.OpenDatabase(NewDbPath) Set rs = TargetDb.OpenRecordset("Settings", dbOpenDynaset) If rs.EOF Then rs.AddNew rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update Else rs.MoveFirst rs.Edit rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update End If rs.Close TargetDb.Close Shell "msaccess.exe """ & NewDbPath & """", vbNormalFocus Application.Quit Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close If Not TargetDb Is Nothing Then TargetDb.Close Exit Sub End Sub Public Function ExtractAttachmentFile() As Boolean On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim rsAttach As DAO.Recordset2 Dim fld As DAO.Field2 Dim dataFolder As String dataFolder = CurrentProject.Path If Dir(dataFolder, vbDirectory) = "" Then MkDir dataFolder End If Set db = CurrentDb Set rs = db.OpenRecordset("Settings") If Not rs.EOF Then Set fld = rs.Fields("DBFiles") If Not IsNull(fld) Then Set rsAttach = fld.Value If Not rsAttach.EOF Then rsAttach.Fields("FileData").SaveToFile dataFolder & "\" & rsAttach.Fields("FileName").Value ExtractAttachmentFile = True End If rsAttach.Close End If End If CleanUp: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Function ErrorHandler: ExtractAttachmentFile = False Resume CleanUp End Function وما يلي كود النموذج لجميع الأجزاء والمكونات داخله :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private bMessage20Displayed As Boolean Private bMessage35Displayed As Boolean Private bMessage50Displayed As Boolean Private LoginAttempts As Integer Dim TimeCount As Long Private Sub Btn_Quit_Click() Dim userResponse As VbMsgBoxResult userResponse = MsgBox("إغلاق النظام؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية الإغلاق") If userResponse = vbYes Then DoCmd.Quit ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If End Sub Private Sub Form_Load() ExtractAttachmentFile LoginAttempts = 0 Me.Caption = "Foksh - Officena.Net - 2025" DoEvents If Check_Auto = -1 Then Me.TimerInterval = 1000 Else Me.TimerInterval = 0 Me.Lbl_Load.Caption = "" End If End Sub Private Sub Form_Timer() Me.TimerInterval = 0 CheckForUpdate End Sub Private Sub ImgUpdate_Click() On Error GoTo ErrorHandler Dim userResponse As VbMsgBoxResult userResponse = MsgBox("التحديث الآن؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية التحديث") If userResponse = vbYes Then UpdateURLSAndOpenNewDatabase ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If ErrorHandler: Resume Next End Sub ما يتم تنفيذه عند استعمال الفكرة :- أولاً عند الفتح للمشروع سيتم استخراج ملف DLL مرفق داخل قاعدة البيانات . ثانياً عند اكتمال التحديث سيتم استبدال النسخة القديمة بالنسخة الجديدة ، وشأنه شأن أي عملية تحديث ؛ فإنك ستفقد النسخة القديمة كاملةً ( وهنا الحاجة الماسة لاعتماد فكرة تقسيم قاعدة البيانات ) . ملف الواجهة المرفق مفتوح المصدر 👈 [ Main.accdb ] * عذراً إن كانت طريقتي في العمل مزعجة أو غريبة نوعاً ما ، لكن هو طبعي 😅 . فماذا أفعل ؟؟!!

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كثير منا يبحث عن QR ( رمز إستجابة سريعة ) ولكن ملوّن !! ونستطيع التحكم باللون حسب حاجته !! اليوم بطريقة بسيطة يتم تنفيذها بكل سلاسة سنحقق ذلك . والفائدة على سبيل المثال :- الإبتعاد عن النمط التقليدي اللون الأسود المعروف به رمز الـ QR .. شكل جمالي ملفت لرمز الإستجابة QR .. التمييز بين الأقسام أو الأستخدام للـ QR حسب حاجة المشروع . فمثلاً ( قسم المحاسبة لهم رمز باللون الأزرق ، قسم الصيانة لهم رمز باللون الأسود ، المعلمين رمز باللون الأحمر ..... إلخ . والكثير من الإستخدامات التي لا تخطر ببالي حالياً . تأكد من تثبيت إصدار NET Framework 4.0 أو أعلى على جهازك . تستطيع التحميل من هذا الرابط ، أو بشكل مباشر من هذا الرابط . برنامج ImageMagick . ويمكنك تحميله من رابط الموقع من هذا الرابط ، أو بشكل مباشر من هذا الرابط . ملفات الـ DLL ( zxing.interop.dll ، zxing.dll ، zxing.interop.tlb ) والتي هي مكتبات سيتم إضافتها الى محرر الأكواد VBA في آكسيس لاحقاً طريقة التثبيت والإضافة ( موجودة في الملف المرفق ) . أولا يلزمنا تسجيل المكتبات المستخدمة في المشروع ( وهنا سنستخدم ZXing لتنفيذ مهمتنا ) وطبعاً سنحتاج مكتبة QRCode ، ويجب تسجيلها ليتم إضافتها في آكسيس في مكتبات الـ VBA > Tools > References . فكيف ننفذ هذه الخطوة المهمة . بعد التأكد من تثبيت المستلزمين السابقين :- افتح موجه الأوامر CMD كمسؤول ( Run as Administrator ) . قم بكتابة السطر التالي لتسجيل المكتبة :- cd C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك قم بكتابة السطر التالي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase zxing.interop.dll ومن المفترض أن تظهر معك النتيجة بهذا الشكل :- أما خلاف ذلك فأن عملية تسجيل المكتبة لم تنجح ولن يتم إضافتها إلى محرر الأكواد VBA كما نريد . الآن لاستكمال عملية تسجيل المكتبة وإضافتها الى محرر الأكواد VBA ، نطبق آخر خطوة وهي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase "C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.dll" /tlb:"C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.tlb" --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\ Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك الآن نفتح قاعدة بيانات جديدة ، ونذهب إلى محرر الأكواد ( Tools > References ) ، ونبحث عن المكتبة التالية كما في الصورة :- الآن وبعد إتمام عملية التسجيل للمكتبة المطلوبة وتثبيت المستلزمات السابقة ، نقوم بإنشاء نموذج يحتوي على مربع نص ، وعنصر صورة ، و زر لتنفيذ العملية . ثم نأتي إلى الأكواد ، وما سنحتاجه الآن هو مديول يحتوي على الدالتين التاليتين :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Function Encode_To_QR_Code_To_File(str As String, Optional foregroundColor As String = "black", Optional backgroundColor As String = "white") As String On Error GoTo ErrorHandler Dim writer As IBarcodeWriter Dim qrCodeOptions As QrCodeEncodingOptions Dim filepath As String Dim folderPath As String folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If filepath = folderPath & "\QRCode_" & Format(Now, "yyyyMMdd_hhmmss") & ".png" Set qrCodeOptions = New QrCodeEncodingOptions Set writer = New BarcodeWriter writer.Format = BarcodeFormat_QR_CODE Set writer.Options = qrCodeOptions qrCodeOptions.Height = 200 qrCodeOptions.Width = 200 qrCodeOptions.CharacterSet = "UTF-8" qrCodeOptions.Margin = 1 qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H writer.WriteToFile str, filepath, ImageFileFormat_Png If Change_QR_Code_Colors_ImageMagick(filepath, foregroundColor, backgroundColor) Then Encode_To_QR_Code_To_File = filepath Else Encode_To_QR_Code_To_File = "" End If Exit Function ErrorHandler: Encode_To_QR_Code_To_File = "" MsgBox "حدث خطأ أثناء إنشاء QR Code: " & Err.Description, vbCritical, "خطأ" End Function Function Change_QR_Code_Colors_ImageMagick(filepath As String, foregroundColor As String, backgroundColor As String) As Boolean On Error GoTo ErrorHandler Dim batchFilePath As String Dim batchContent As String Dim result As Long If Dir(filepath) = "" Then MsgBox "لم يتم العثور على الملف: " & filepath, vbCritical, "خطأ" Exit Function End If batchContent = "@echo off" & vbCrLf & "magick " & Chr(34) & filepath & Chr(34) & " -fill " & foregroundColor & " -opaque black -fill " & backgroundColor & " -opaque white " & Chr(34) & filepath & Chr(34) batchFilePath = Environ$("temp") & "\ChangeQRColors.bat" Open batchFilePath For Output As #1 Print #1, batchContent Close #1 result = Shell("powershell -Command Start-Process " & Chr(34) & batchFilePath & Chr(34) & " -Verb RunAs", vbHide) DoEvents Sleep 3000 If Dir(filepath) <> "" Then Change_QR_Code_Colors_ImageMagick = True Else Change_QR_Code_Colors_ImageMagick = False End If Kill batchFilePath Exit Function ErrorHandler: Change_QR_Code_Colors_ImageMagick = False MsgBox "حدث خطأ أثناء تغيير ألوان QR Code: " & Err.Description, vbCritical, "خطأ" End Function وفي حدث عند النقر لزر التنفيذ ، الكود التالي :- Private Sub Command20_Click() Dim imagePath As String Dim folderPath As String If IsNull(Me.Text0) Or Me.Text0 = "" Then MsgBox "QR Code الرجاء إدخال نص لإنشاء", vbExclamation, "" Exit Sub End If Dim foregroundColor As String Dim backgroundColor As String foregroundColor = "Blue" backgroundColor = "white" imagePath = Encode_To_QR_Code_To_File(Me.Text0, foregroundColor, backgroundColor) If imagePath <> "" Then Me.Image0.Picture = imagePath MsgBox " بنجاح QR Code تم إنشاء", vbInformation, "" folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" Else MsgBox "فشل في إنشاء QR Code", vbCritical, "" End If End Sub الآن لتغيير ألوان الـ QR كخلفية أو لون الرمز نفسه ، تستطيع التعديل من خلال السطرين التاليين في زر التنفيذ :- foregroundColor = "Blue" <---- هنا لون الرمز نفسه backgroundColor = "white" <---- هنا لون الخلفية وهنا نكون قد وضحنا المطلوب وطريقة تنفيذه خطوة بخطوة .. QrCodeZXing.zip

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

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة لأنشاء الجداول بطريقة مختلفة عن الطريقة التقليدية التي نعرفها .. إلا أنها ما زالت قيد التطوير الفكرة تعتمد على نموذج واحد فقط يمكّن المستخدم من إنشاء جداوله والحقول التي تحتويها ونوع الحقول بشكل سهل وبسيط . أولاً انقر على الزر " أنشاء حقل جديد ... " ثانياً قم بملئ الحقول ( اسم الجدول ، اسم الحقل ، نوع الحقل ) ، عند اختيار نوع الحقل سيتم إضافة الحقل الجديد الى الـ List Box تسلسلاً حسب الإدخال . عند الإنتهاء من إدخال جميع الحقول وأنواعها ، انقر الزر " إنشاء الجدول ... " ، وهنا سيتظهر رسالة تفيد بأنه ( لابد من وجود حقل مفتاح أساسي ، هل ترغب بتعيين حقل مفتاح أساسي ؟ ) عند اختيار Yes - نعم سيتم تعيين أول حقل كمفتاح أساسي ؛ وإذا تم اختيار No - لا سيتم انشاء الجدول دون مفتاح أساسي . عند إنشاء الجدول سيتم تصحيح عدة نقاط بشكل تلقائي وهي :- إزالة المسافة من اسماء الجداول واستبدالها بـ " _ " . إضافة الجزء "_Tbl" الى اسم الجدول عند انشائه . أيضاً إزالة المسافة من أسماء الحقول واستبدالها بـ " _ " . الملف مفتوح المصدر TBL Maker.accdb بناءً على إقتراحات أستاذي وصديقي @Moosak ، والتعديلات التي تقدم بها صديقي وأستاذي @ابو جودي ، تم دمج وإضافة تعديلات جديدة أرجو أن تنال رضاكم وإعجابكم . تم إضافة ميزة أن يكون في الجدول أكثر من حقل مفتاح أساسي . تم إضافة ميزة التعديل على الحقول أو حذف أحد الحقول قبل إنشاء الجدول من خلال زر " تعديل الحقول " ، وبعد إجراء التعديلات انقر زر " تأكيد التعديل ". تم دمج ميزة حرية إضافة " _Tbl " الى اسم الجدول عند انشائه ( فكرة الأستاذ أبو جودي مع إجراء تعديل بسيط ) - إختياري . تم دمج ميزة أن يكون أسماء الجداول والحقول ( الإنجليزية ) تبدأ بحرف كبير Capital Letter . تم إضافة ميزة فتح الجدول بعد انشائه لرؤية النتيجة أو لإدخال البيانات - إختياري . تم إضافة زر " مفتاح أساسي " لتمكين المستخدم من اختيار الحقول التي يريدها أن تكون مفتاح أساسي . تم إضافة زر " إضافة حقل " لإضافة حقل جديد . تم تعديل التصميم بشكل بسيط ليتناسب مع محتوياته والميزات الجديدة . ✔ لا حاجة لأي مكتبات أو مديولات عند نسخ النموذج لمشروعك والبدء بالإستفادة من ميزاته . ✔ أتطلع لأي أفكار جديدة أو اقتراحات TBL Maker.accdb680 kB · 7 downloads تم إضافة نموذج لإنشاء العلاقات من خلال البرنامج بشكل بسيط بحيث :- يتم اختيار الجدول الأول ، ثم الحقل الذي نرغب بانشاء علاقة له ، ثم اختيار الجدول الثاني وكذلك الأمر اختيار الحقل الثاني الذي سيكون على علاقة مع الحقل السابق يتم التعرف على نوع بيانات الحقول التي تم اختيارها للتأكيد على انك كمستخدم تعرف أنواع البيانات في الحقلين . أيضاً يتم التعرف على الحقل ما إذا كان مقتاح أساسي أم لا . عند النقر على زر نوع العلاقة ، فسيتم اظهار نوع العلاقة المنطقية لهذين الحقلين . في الزر انشاء العلاقات سيتم انشاء العلاقة بشكل تلقائي بين الجدولين مع تفعيل تتالي الحذف والإضافة . لإختبار ما اذا كان هناك علاقة بين الجدولين ، من خلال الزر تحقق سيظهر لك نتيجة العلاقة إذا كانت موجودة ونوعها والحقول التي بينها علاقة في الجدولين . عند وجود علاقة سابقة بين الجدولين سيتم تنبيه المستخدم بوجود علاقة سابقة ، هل ترغب باستبدال العلاقة السابقة بعلاقة جديدة ؟؟ وفي حال الموافقة سيتم حذف العلاقة القديمة واستبدالها بالعلاقة الجديدة . طبعاً هنا يجب التنويه أن البرنامج لن يقوم بإنشاء أي علاقة غير صحيحة بين اي حقلين نهائياً . تم اضافة زر لحذف العلاقة بشكل اختياري بين اي جدولين بينهم علاقة . لإجراءاتكم بالتجربة وإفادتي بالنقاط التي قد أكون قد غفلت عنها . TBL Maker.accdb

السلام عليكم ورحمة الله وبركاته.. كنت اعمل على مشروع للقرآن الكريم، يكون ضمن تطبيق قوت القلوب، صورته في التوقيع 🥰 البرنامج من تصميمي وبرمجتي 100% فاحتجت للقرآن الكريم مرتل ومقسم لايات قمت بالعثور على ختمات كاملة وللعديد من القرآء في موقع Archive.org فقمت بتحويل الروابط الى قاعدة بيانات SQLite تتضمن ترتيل القرآن الكريم على شكل ايات كل آية على حدا وبرابط مباشر، أي ستقوم بتشغيل الصوت من الرابط مباشرة بدون تنزيلة طبعا يمكنكم تشغيل الصوت مباشرة من الويب باستخدام الكثير من المكتبات المجانية مثل NAudio.dll وغيرها... قبل كل شيء، هذا الكود لإنشاء الجدول sounds الذي ستكون فيه روابط الصوت لايات القرآن الكريم في قاعدة البيانات.. 1. تسلسل السورة 2. رقم الآية 3. رابط الملف الصوتي للآية 4. معرف القارئ CREATE TABLE "sounds" ( "surah_number" INTEGER, "ayah_number" INTEGER, "audio_url" TEXT, "reader_id" INTEGER ); 0. احمد نعينع 1. الطبلاوي 2. عبد الباسط 3. المنشاوي 4. الحصري السورس كود للفائدة، الذي يقوم بتوليد الايات حسب السور بلغة NET. Sub GenerateQuranAudioLinks(ByVal baseUrl As String, ByVal reader_id As String) ' عدد الآيات لكل سورة من القرآن الكريم Dim surahAyatCounts As Integer() = { 7, 286, 200, 176, 120, 165, 206, 75, 129, 109, 123, 111, 43, 52, 99, 128, 111, 110, 98, 135, 112, 78, 118, 64, 77, 227, 93, 88, 69, 60, 34, 30, 73, 54, 45, 83, 182, 88, 75, 85, 54, 53, 89, 59, 37, 35, 38, 29, 18, 45, 60, 49, 62, 55, 78, 96, 29, 22, 24, 13, 14, 11, 11, 18, 12, 12, 30, 52, 52, 44, 28, 28, 20, 56, 40, 31, 50, 40, 46, 42, 29, 19, 36, 25, 22, 17, 19, 26, 30, 20, 15, 21, 11, 8, 8, 19, 5, 8, 8, 11, 11, 8, 3, 9, 5, 4, 7, 3, 6, 3, 5, 4, 5, 6 } ' حلقة لتوليد جمل SQL لكل سورة وآياتها For surah As Integer = 1 To 114 Dim surahNumber As String = surah.ToString("D3") ' تحويل رقم السورة إلى 3 أرقام Dim ayatCount As Integer = surahAyatCounts(surah - 1) ' توليد جمل SQL بناءً على عدد الآيات لكل سورة For ayah As Integer = 0 To ayatCount Dim ayahNumber As String = ayah.ToString("D3") ' تحويل رقم الآية إلى 3 أرقام Dim fileUrl As String = baseUrl & surahNumber & ".zip" & "/" & surahNumber & ayahNumber & ".mp3" Dim sqlInsert As String = "INSERT INTO sounds (surah_number, ayah_number, audio_url, reader_id) VALUES (" & surah & "," & ayah & "," & "'" & fileUrl & "'" & "," & reader_id & ");" My.Computer.FileSystem.WriteAllText(Application.StartupPath & "\sql_" & reader_id & ".txt", sqlInsert & vbNewLine, True) Next Next '' تشغيل كل عملية في ثريد منفصل باستخدام Task 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb---a7mad--n3ena3---morattal------quran----6236---ayaat-----__verse--by---_189/", "1")) 'احمد نعينع 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb__---mp3------------quran----6236---ayaat-----__verse--by---verse----_-by-/", "2")) 'الطبلاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/192kb----morattal----quran----6236---ayaat-----__verse--by---verse----_-by--ab_525/", "3")) 'عبد الباسط 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb____--mp3-------full-----quran----6236---ayaat-----__verse--by---verse---/", "4")) 'المنشاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb___--mp3-----quran----6236---ayaat-----__verse--by---verse----_-by---alhos/", "5")) 'الحصري End Sub ارفقت لكم البيانات على شكل ملفات TXT لكي تعدلو عليها كيفما شئتم. لا تنسوني ووالدي من صالح دعائكم SQLite.zip

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكن بطريقة ونكهة مختلفتين ▫▪◽◾◻◼. "أداة مستورد السجلات الذكي من Excel" ، أداة مبتكرة تتيح لك استيراد البيانات من ملفات Excel إلى قواعد بيانات Access بكل مرونة وسرعة . يتميز هذا البرنامج أو الأداة بواجهة بسيطة وميزات قوية تجعل التعامل مع البيانات تجربة مريحة ، حتى للمستخدمين الذين ليست لديهم خبرة تقنية كبيرة في التعامل مع هذا النوع من المتطلبات . فالكثير من الأشخاص في منتدانا هنا سأل عن إمكانية استيراد بيانات من اكسل من حقل محدد أو بطرق محددة ( تناسب إحتياجاته ) ، ولهذا كانت الفكرة هذه تنفيذاً لمتطلباتهم .. 🎯 سنستعرض أهم ميزات هذا البرنامج وكيف يمكن أن يسهم في تحسين إنتاجيتك وتوفير وقتك . تابع القراءة لاكتشاف كيف يمكنك الاستفادة من هذا الحل الذكي لإدارة البيانات 😇 . ميزات برنامج مستورد السجلات الذكي من Excel 📂 التكامل مع Excel يمكن اختيار ملفات Excel بسهولة باستخدام نافذة اختيار الملفات . يدعم البرنامج ملفات بصيغة xls / xlsx . 📋 التعامل مع الأوراق والبيانات عرض جميع أوراق العمل (Sheets) الموجودة في ملف Excel المحدد . عرض أسماء الأعمدة في الورقة المحددة لتسهيل تحديد العمود المستهدف . 🚀 الاستيراد المرن للبيانات استيراد بيانات من عمود محدد في ملف Excel بناءً على اختيار المستخدم . تحديد الصفوف التي تبدأ منها عملية الاستيراد (لتجاوز رؤوس الأعمدة إن وجدت 👌 ) . 🗂️ الإدارة المتقدمة للبيانات داخل Access استيراد البيانات إلى جدول محدد داخل قاعدة البيانات الحالية . دعم لتحديد الحقول الهدف داخل الجدول . إمكانية تفعيل خاصية الترقيم التلقائي لإضافة قيم تسلسلية إلى الحقول المخصصة ( باستخدام الدالة DMAX ). ⚡ أداء عالي مع دفعات من البيانات تقسيم البيانات إلى دفعات عند استيراد كميات كبيرة لتجنب مشاكل الأداء . إدارة مرنة لعدد السجلات التي يتم استيرادها في كل دفعة . 🎨 واجهة مستخدم ديناميكية إظهار أو إخفاء المساعدة البصرية بضغطة زر . تحديث الكومبوبوكس بطريقة ديناميكيًا بناءً على اختيارات المستخدم . 🔒 إجراءات أمان واسترجاع دعم لاسترجاع البيانات عند حدوث خطأ أثناء عملية الاستيراد ( Rollback ) . التنبيه برسائل خطأ واضحة إذا لم يتم اختيار الملف أو إعداد الخيارات بشكل صحيح . 🧹 إدارة الموارد تنظيف جميع الموارد المفتوحة (ملفات Excel أو الاتصال بالبيانات) عند إغلاق النموذج . منع أي تأثير سلبي على النظام عند حدوث خطأ . ✨ سهولة الاستخدام تصميم بسيط يعرض التعليمات ويطلب إدخال البيانات الضرورية فقط . رسائل توجيهية للمستخدم لتحسين تجربة الاستخدام . ⚙️ المرونة في تخصيص الخيارات خيارات لتحديث السجلات الموجودة أو إضافة سجلات جديدة . دعم مجموعات البيانات المختلفة من خلال تحديد طريقة المعالجة . صورة واجهة الأداة .. الملف المرفق مفتوح المصدر .. 💢 Excel Importor.accdb 💢 **************************** ما الجديد في هذا للتحديث ؟ 📊 واجهة المستخدم (UI) : واجهة مستخدم تحتوي على أزرار وخيارات لتسهيل عملية استيراد البيانات من إكسل إلى أكسيس . 📂 يمكن للمستخدم اختيار ملف إكسل من خلال مربع حوار اختيار الملفات . يتم تحميل بيانات الملف المحدد وعرض أسماء الأوراق (Sheets) والأعمدة (Columns) في القوائم المنسدلة . 📥 يدعم الكود طريقتين لاستيراد البيانات : 🔢 استيراد عمود واحد ( الإصدار الأول ): حيث يتم استيراد بيانات عمود معين من إكسل إلى حقل محدد في جدول أكسيس. 🔢🔢 استيراد عدة أعمدة ( بناءً على طلب الأخوة ): حيث يتم استيراد بيانات عدة أعمدة من إكسل إلى عدة حقول في جدول أكسيس. 💥 يتم التحقق من صحة البيانات المحددة قبل بدء عملية الاستيراد . 🔢 إدارة الترقيم التلقائي : يدعم البرنامج إمكانية الترقيم التلقائي للحقول المحددة أثناء عملية الاستيراد . يمكن للمستخدم تفعيل أو تعطيل هذه الميزة وتحديد الحقل الذي سيتم الترقيم التلقائي عليه . ⚠️ إدارة الأخطاء : يتم التعامل مع الأخطاء المحتملة أثناء عملية الاستيراد ( مثل عدم وجود ملف إكسل محدد أو عدم تطابق الأعمدة ... إلخ ) . الملف المرفق مفتوح المصدر .. 💢 Excel Importor 2025.accdb1.07 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 20 downloads 💢 🔴 وجب علي التنويه إلى نقطة مهمة وهي :- قد يأتي أحد الأخوة لاختيار ملف يحتوي على ترويسة أو صورة في أول ملف الإكسل الذي اختاره ، ويقول لي أنه لم يظهر لي أي أسماء للأعمدة التي تحدثت عنها ( وأن الأداة لم تخدمه بشكل أو بآخر ) وهنا وأعتذر منه مسبقاً بأن هذا الخلل ليس في الأداة وإنما في ملف الآكسل . فأنا لا استطيع أن أجبرك على تصميم معين لملف الآكسل الذيتريد الإستيراد منه ، ولكني بنفس الوقت أقترح عليك أن تزيل هذه الإضافات والمعوقات كي تستفيد من الأداة بشكل ممتاز . ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 في التحديث الجديد ، تم الإعتماد على الفكرة المطروحه هنا في هذا الموضوع " رافع ملفات جوجل درايف 2025 " ، لكن مع اختلاف بسيط جزئي كما أخبارناكم سابقاً .. تم إضافة الفكرة بعد استكمالها ، وبناءً على طلب الأساتذة لتكتمل الفكرة من جميع الجوانب ( ملف اكسيل محل ، أو مرفوق على جوجل شيت أو ملف اكسيل مرفوع برابط مباشر في جوجل درايف - يتم تحويله الى جوجل شيت . فقط اختر الرابط ( نسخ ولصق ) وادخاله في رسالة رابط الملف كما في الصورة التالية :- الأداة بتحديثها الجديد تدعم استكمال الجلسة لآخر رابط تم استخدامه ( توفيراً للوقت واختصاراً لفكرة استخدام الرابط نفسه في كل مرة ) ، بحيث تظهر لك رسالة كالآتي :- بحيث اذا كان اختيارك لـ Yes يتم التعرف على آخر رابط تم استخدامه ( حتى بعد اغلاق الأداة ) ، وإذا كان رد المستخدم No يتم اظهار رسالة ادخال رابط جديد ( ويتم اعتماده للجلسة اللاحقة ) .. الأداة تحتوي على معالج مساعد لمساعدة المستخدم ( أول مرة فقط ) على انشاء حساب في جوجل درايف وكيفية التعامل مع الـ API الخاصة بـ Google Sheets لتهيئة الأداة للتعامل مع روابط جوجل شيت لاستيراد السجلات منه . في التحديث الجديد للأداة ، يتم التعرف على الأخطاء التي يمكن حصولها أثناء اختيار حقل وخلية لا يوجد بينهما توافق في نوع البيانات ، فمثلاً لو تم اختيار خليه تحتوي على تاريخ ويقابلها حقل في الجدول ( في آكسيس ) من نوع رقمي مثلاً ، فإن الاداة تخبرك بنوع الحقل والتصحيح الذي يمكن تعديله .. الفكرة الحالية نفسها كما هو التعامل مع ملف محلي ( ملف اكسيل داخل الكمبيوتر ) لا تختلف في التعامل وطريقة الإستخدام كلياً .. واجهة الأداة :- * صورة من الواجهة الخاصة بـ Google Sheets . يلزم إضافة مكتبة Microsoft Office xx.0 Object Library فقط .. ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 إصلاح مشكلة الإستيراد لأكثر من سجل من جوجل شيت . في الإصدار الأخير السابق وأتوجه بالشكر للأستاذ @Moosak للفته انتباهي لهذا الخلل . فقد تم بحمد الله تلافي وحل المشكلة من جذورها وإضافة ميزة جديدة وهي التعرف على طول القيمة التي سيتم استيرادها ( للحقول النصية ) . حيث طول الحقل النصي في اكسيس 255 حرف . وبهذا لا يمكن استيراد كامل القيمة اذا كانت أكبر من 255 حرف ، وسيتم ترك الفكرة للمستخدم بأن يكمل الإستيراد بعد ان يتم تقليص قيمة الخليه من جوجل شيت الى 255 أو الغاء العملية بالكامل .. وعليه ، فإن التعديل الجديد حل هذه المشكلة وغيرها .. ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ------------------------------ Excel Importor 2.0.zip757.56 kB · 1 download ------------------------------ ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي DurationToFullWords ، وهي تقوم بحساب الفارق بين تاريخين معينين (StartDate و EndDate) وتنسيق النتيجة بشكل نصي باستخدام الوحدات الزمنية مثل "سنة" ، "شهر" ، و "يوم" . كما تدعم العديد من الخيارات لتخصيص المخرجات مثل تحديد تنسيق النتيجة وإظهار الأرقام مع الكلمات العربية . 1️⃣ الجزء الأول تعريف المعاملات والتأكد من صحة البيانات المدخلة :- وقد تم تعديل الفكرة بحيث يستقبل الكود التاريخين الأصغر أولاً ثم الأكبر بغض النظر عن ما اذا كان مربع النص الأول يضم تاريخ أكبر أم أصغر .. If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If حيث StartDate و EndDate هما التاريخان اللذان يتم مقارنة الفارق بينهما . أولاً يتم التأكد من أن كلا التاريخين مدخلين بشكل صحيح (غير فارغين) . ثم يقارن اي القيمتين أسغر لجعلها بداية والأكبر نهاية 😁 . 2️⃣ الجزء الثاني حساب الفارق بين التواريخ :- y = DateDiff("yyyy", tempDate, EndDate) m = DateDiff("m", tempDate, EndDate) d = DateDiff("d", tempDate, EndDate) totalDays = DateDiff("d", StartDate, EndDate) حيث DateDiff هي دالة تستخدم لحساب الفرق بين التواريخ بوحدات مختلفة مثل السنوات (yyyy) ، الأشهر (m) ، و الأيام (d) . فيتم حساب الفرق بالسنوات أولاً ، ثم الأشهر ، وأخيراً الأيام . ثم يتم جمع totalDays لحساب الفارق الإجمالي بالأيام بين التاريخين . 3️⃣ الجزء الثالث المعالجة الخاصة للأشهر والأيام :- If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If حيث RoundResults هو خيار اختياري لتقريب النتائج . فإذا كان هذا الخيار مفعلًا ، يتم تعديل الأشهر أو الأيام ليتم تقريبها بشكل منطقي . فإذا كانت الأشهر 11 شهراً والأيام 25 أو أكثر ، يتم زيادة السنة بمقدار واحد . وإذا كانت الأشهر 5 والأيام 25 أو أكثر ، يتم تحويل الأشهر إلى 6 . 4️⃣ الجزء الرابع تنسيق النتائج حسب الخيارات :- Select Case FormatOption Case "Y" ' تنسيق الفرق بالسنوات فقط Case "M" ' تنسيق الفرق بالأشهر فقط Case "D" ' تنسيق الفرق بالأيام فقط Case "M/D" ' تنسيق الفرق بالأشهر والأيام Case "Y/M" ' تنسيق الفرق بالسنوات والأشهر Case Else ' تنسيق كامل (سنوات، أشهر، أيام) End Select التوضيح على شكل نقاط :- تعتمد الدالة على FormatOption لتحديد التنسيق الذي يجب أن تظهر به النتيجة ، كالتالي :- Y : يعرض النتيجة بالسنوات فقط . M : يعرض النتيجة بالأشهر فقط . D : يعرض النتيجة بالأيام فقط . M/D : يعرض النتيجة بالأشهر والأيام . Y/M : يعرض النتيجة بالسنوات والأشهر . القيمة الافتراضية : يعرض النتيجة كاملة (سنوات ، أشهر ، أيام) . 5️⃣ الجزء الخامس الدوال المساعدة :- Function SimpleUnit(Number As Long, UnitName As String) As String وتقوم هذه الدالة بـ :- بتنسيق الأرقام مع الوحدات الزمنية مثل "سنة" ، "شهر" ، أو "يوم" . تتعامل مع العدد بصيغة الجمع أو المفرد حسب الرقم المدخل . على سبيل المثال ، إذا كان العدد 1 ، يتم إرجاع "1 سنة" أو "1 شهر"، وإذا كان العدد 2 يتم إرجاع "سنتين" أو "شهرين" ... إلخ . Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String وتقوم هذه الدالة بتنسيق الأرقام مع الوحدات بشكل معين . على سبيل المثال :- OnlyNumbers : إذا كان True ، تعرض الأرقام فقط . ShowNumberWithWord : إذا كان True ، تعرض الرقم مع الكلمة باللغة العربية في قوسين مثل : "5 (خمسة) سنوات" . Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية . كما أنها تدعم الكلمة بصيغة المذكر أو المؤنث حسب القيمة المدخلة في IsFeminine . Function NumberWithUnitArabic(Number As Long, UnitName As String) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية مع الوحدة المناسبة (مثل "سنة واحدة" ، "شهران" ، "أيام") . 6️⃣ الجزء السادس التعامل مع الحروف العطف (مثل "و" ) .في الجزء :- If Right(result, 3) = " و " Then result = Left(result, Len(result) - 3) End If فبعد تنسيق النتيجة ، يتم إزالة الفاصلة الزائدة "و" في النهاية إذا كانت موجودة . 7️⃣ الجزء السابع : النتيجة النهائية :- If result = "" Then result = "أقل من يوم" DurationToFullWords = result في حال كانت النتيجة فارغة ( قيمة بفارق 0 ) ، يتم تعيين النتيجة إلى "أقل من يوم" . 💢 تم إضافة دالة تقوم بتفقيط التاريخ بأكثر من شكل ( 3 تنسيقات ) ، على سبيل المثال ، تاريخ اليوم هو 08/04/2025 والنتيجة له :- الثامن من شهر نيسان لعام ألفين وخمسة وعشرين م الثامن من شهر أبريل لعام ألفين وخمسة وعشرين م والجزء الجديد هو قراءة التاريخ بالأشهر الهجرية :- الثامن من شهر ربيع ثان لعام ألفين وخمسة وعشرين هـ 📛 الآن الكود العام في مديول منفرد :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit Function DurationToFullWords(StartDate As Variant, EndDate As Variant, _ Optional FormatOption As String = "", _ Optional ShortFormat As Boolean = False, _ Optional OnlyNumbers As Boolean = False, _ Optional ShowNumberWithWord As Boolean = False, _ Optional RoundResults As Boolean = False) As String If FormatOption = "" Then FormatOption = "FullWords" Dim y As Long, m As Long, d As Long Dim tempDate As Date Dim Result As String Dim totalMonths As Long Dim totalDays As Long Dim weeks As Long If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If tempDate = StartDate totalDays = DateDiff("d", StartDate, EndDate) y = DateDiff("yyyy", tempDate, EndDate) If DateAdd("yyyy", y, tempDate) > EndDate Then y = y - 1 tempDate = DateAdd("yyyy", y, tempDate) m = DateDiff("m", tempDate, EndDate) If DateAdd("m", m, tempDate) > EndDate Then m = m - 1 tempDate = DateAdd("m", m, tempDate) d = DateDiff("d", tempDate, EndDate) totalMonths = (y * 12) + m weeks = totalDays \ 7 If ShortFormat Then If y > 0 Then Result = Result & SimpleUnit(y, "سنة") & " و " If m > 0 Then Result = Result & SimpleUnit(m, "شهر") & " و " If d > 0 Then Result = Result & SimpleUnit(d, "يوم") & " و " Else If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If End If Select Case FormatOption Case "Y" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) Else If m < 6 Then Result = "أقل من نصف سنة" ElseIf m = 6 And d = 0 Then Result = "نصف سنة" ElseIf m = 6 And d > 0 Then Result = "أكثر من نصف سنة" ElseIf m > 6 Then Result = "أكثر من نصف سنة" End If End If Case "M" If totalMonths > 0 Then Result = FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) ElseIf d > 0 Then If d = 30 Or d = 31 Then Result = "شهر" ElseIf d < 30 Then Result = "أقل من شهر" End If Else Result = "أقل من شهر" End If Case "D" Result = FormatNumberWithWord(totalDays, "يوم", OnlyNumbers, ShowNumberWithWord) Case "M/D" If totalMonths > 0 Then Result = Result & FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) If d > 0 Then Result = Result & " و " End If If d > 0 Then If d >= 7 And totalMonths = 0 Then Select Case weeks Case 1 Result = Result & "أسبوع" Case 2 Result = Result & "أسبوعان" Case 3 To 4 Result = Result & FormatNumberWithWord(weeks, "أسبوع", OnlyNumbers, ShowNumberWithWord) Case Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End If End If Case "Y/M" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) Case Else If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) & " و " If d > 0 Then Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select End If If Right(Result, 3) = " و " Then Result = Left(Result, Len(Result) - 3) End If If Result = "" Then Result = "أقل من يوم" DurationToFullWords = Result End Function Function SimpleUnit(Number As Long, UnitName As String) As String Select Case Number Case 1 SimpleUnit = "1 " & UnitName Case 2 If UnitName = "سنة" Then SimpleUnit = "2 سنتين" ElseIf UnitName = "يوم" Then SimpleUnit = "2 يومين" Else SimpleUnit = "2 " & UnitName & "ين" End If Case 3 To 10 If UnitName = "سنة" Then SimpleUnit = Number & " سنوات" ElseIf UnitName = "شهر" Then SimpleUnit = Number & " أشهر" ElseIf UnitName = "يوم" Then SimpleUnit = Number & " أيام" Else SimpleUnit = Number & " " & UnitName End If Case Else SimpleUnit = Number & " " & UnitName End Select End Function Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String If OnlyNumbers Then FormatNumberWithWord = SimpleUnit(Number, UnitName) ElseIf ShowNumberWithWord Then FormatNumberWithWord = Number & " (" & NumberToArabicUnit(Number, UnitName) & ")" Else FormatNumberWithWord = NumberToArabicUnit(Number, UnitName) End If End Function Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String Dim UnitsMasc, UnitsFem, Tens, TeensMasc, TeensFem, Hundreds UnitsMasc = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") UnitsFem = Array("", "واحدة", "اثنتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع") TeensMasc = Array("عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") TeensFem = Array("عشر", "إحدى عشرة", "اثنتا عشرة", "ثلاث عشرة", "أربع عشرة", "خمس عشرة", "ست عشرة", "سبع عشرة", "ثماني عشرة", "تسع عشرة") Tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") Hundreds = Array("", "مئة", "مئتان", "ثلاثمئة", "أربعمئة", "خمسمئة", "ستمئة", "سبعمئة", "ثمانمئة", "تسعمئة") Dim Words As String Dim n As Long Dim h, t, u As Integer If Number = 0 Then NumberToArabicWords = "صفر" Exit Function End If If Number = 10 Then NumberToArabicWords = IIf(IsFeminine, "عشر", "عشرة") Exit Function End If If Number > 999 Then Dim Thousands As Long Thousands = Number \ 1000 Words = NumberToArabicWords(Thousands, False) & " ألف" n = Number Mod 1000 If n > 0 Then Words = Words & " و " & NumberToArabicWords(n, IsFeminine) NumberToArabicWords = Words Exit Function End If h = Number \ 100 t = (Number Mod 100) \ 10 u = Number Mod 10 If h > 0 Then Words = Hundreds(h) If (Number Mod 100) >= 11 And (Number Mod 100) <= 19 Then If Words <> "" Then Words = Words & " و " If IsFeminine Then Words = Words & TeensFem((Number Mod 100) - 10) Else Words = Words & TeensMasc((Number Mod 100) - 10) End If Else Dim UnitsArray UnitsArray = IIf(IsFeminine, UnitsFem, UnitsMasc) If t > 1 Then If u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) & " و " & Tens(t) Else If Words <> "" Then Words = Words & " و " Words = Words & Tens(t) End If ElseIf u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) End If End If NumberToArabicWords = Words End Function Function NumberWithUnitArabic(Number As Long, UnitName As String) As String Dim Result As String Select Case UnitName Case "سنة" Select Case Number Case 1: Result = "سنة واحدة" Case 2: Result = "سنتان" Case 3 To 10: Result = Number & " سنوات" Case Else: Result = Number & " سنة" End Select Case "شهر" Select Case Number Case 1: Result = "شهر واحد" Case 2: Result = "شهران" Case 3 To 10: Result = Number & " أشهر" Case Else: Result = Number & " شهر" End Select Case "يوم" Select Case Number Case 1: Result = "يوم واحد" Case 2: Result = "يومان" Case 3 To 10: Result = Number & " أيام" Case Else: Result = Number & " يوم" End Select Case Else Result = Number & " " & UnitName End Select NumberWithUnitArabic = Result End Function Function NumberToArabicUnit(Number As Long, UnitName As String) As String Dim word As String Dim feminine As Boolean Select Case UnitName Case "سنة": feminine = True Case "شهر": feminine = False Case "يوم": feminine = False End Select Select Case Number Case 1 word = UnitName & " " & IIf(feminine, "واحدة", "واحد") Case 2 If feminine Then word = "سنتان" Else If UnitName = "يوم" Then word = "يومان" Else word = UnitName & "ان" End If End If Case 3 To 10 word = NumberToArabicWords(Number, feminine) If UnitName = "يوم" Then word = word & " أيام" ElseIf UnitName = "سنة" Then word = word & " سنوات" ElseIf UnitName = "شهر" Then word = word & " أشهر" End If Case Else word = NumberToArabicWords(Number, feminine) & " " & UnitName End Select NumberToArabicUnit = word End Function Function ConvertDateToText(ByVal DateValue As Date, _ Optional ByVal CalendarType As String = "Gregorian", _ Optional ByVal MonthNameStyle As String = "Standard") As String Dim dayNumber As Integer Dim monthNumber As Integer Dim yearNumber As Integer Dim dayText As String Dim monthText As String Dim yearText As String If LCase(CalendarType) = "hijri" Then dayNumber = Val(Format$(DateValue, "dd", vbCalHijri)) monthNumber = Val(Format$(DateValue, "mm", vbCalHijri)) yearNumber = Val(Format$(DateValue, "yyyy", vbCalHijri)) Else dayNumber = day(DateValue) monthNumber = month(DateValue) yearNumber = year(DateValue) End If Select Case dayNumber Case 1: dayText = "الأول" Case 2: dayText = "الثاني" Case 3: dayText = "الثالث" Case 4: dayText = "الرابع" Case 5: dayText = "الخامس" Case 6: dayText = "السادس" Case 7: dayText = "السابع" Case 8: dayText = "الثامن" Case 9: dayText = "التاسع" Case 10: dayText = "العاشر" Case 11: dayText = "الحادي عشر" Case 12: dayText = "الثاني عشر" Case 13: dayText = "الثالث عشر" Case 14: dayText = "الرابع عشر" Case 15: dayText = "الخامس عشر" Case 16: dayText = "السادس عشر" Case 17: dayText = "السابع عشر" Case 18: dayText = "الثامن عشر" Case 19: dayText = "التاسع عشر" Case 20: dayText = "العشرين" Case 21: dayText = "الحادي والعشرين" Case 22: dayText = "الثاني والعشرين" Case 23: dayText = "الثالث والعشرين" Case 24: dayText = "الرابع والعشرين" Case 25: dayText = "الخامس والعشرين" Case 26: dayText = "السادس والعشرين" Case 27: dayText = "السابع والعشرين" Case 28: dayText = "الثامن والعشرين" Case 29: dayText = "التاسع والعشرين" Case 30: dayText = "الثلاثين" Case 31: dayText = "الحادي والثلاثين" Case Else: dayText = CStr(dayNumber) End Select If LCase(CalendarType) = "hijri" Then monthText = Choose(monthNumber, _ "محرم", "صفر", "ربيع أول", "ربيع ثان", "جمادى أول", "جمادى ثان", _ "رجب", "شعبان", "رمضان", "شوال", "ذو القعدة", "ذو الحجة") ElseIf LCase(MonthNameStyle) = "syriac" Then monthText = Choose(monthNumber, _ "كانون الثاني", "شباط", "آذار", "نيسان", "أيار", "حزيران", _ "تموز", "آب", "أيلول", "تشرين الأول", "تشرين الثاني", "كانون الأول") Else monthText = Choose(monthNumber, _ "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") End If yearText = NumberToArabicText(yearNumber) Dim eraSuffix As String If LCase(CalendarType) = "hijri" Then eraSuffix = " هـ" Else eraSuffix = " م" End If ConvertDateToText = dayText & " من شهر " & monthText & " لعام " & yearText & eraSuffix End Function Function NumberToArabicText(ByVal TheNumber As Long) As String Dim MyArray1(0 To 9) As String Dim MyArray2(0 To 9) As String Dim MyArray3(0 To 9) As String Dim Result As String Dim Hundreds As String Dim Tens As String Dim Ones As String Dim AndConnector As String AndConnector = " و" MyArray1(0) = "" MyArray1(1) = "مائة" MyArray1(2) = "مائتين" MyArray1(3) = "ثلاثمائة" MyArray1(4) = "أربعمائة" MyArray1(5) = "خمسمائة" MyArray1(6) = "ستمائة" MyArray1(7) = "سبعمائة" MyArray1(8) = "ثمانمائة" MyArray1(9) = "تسعمائة" MyArray2(0) = "" MyArray2(1) = " عشر" MyArray2(2) = "عشرين" MyArray2(3) = "ثلاثين" MyArray2(4) = "أربعين" MyArray2(5) = "خمسين" MyArray2(6) = "ستين" MyArray2(7) = "سبعين" MyArray2(8) = "ثمانين" MyArray2(9) = "تسعين" MyArray3(0) = "" MyArray3(1) = "واحد" MyArray3(2) = "اثنين" MyArray3(3) = "ثلاثة" MyArray3(4) = "أربعة" MyArray3(5) = "خمسة" MyArray3(6) = "ستة" MyArray3(7) = "سبعة" MyArray3(8) = "ثمانية" MyArray3(9) = "تسعة" If TheNumber = 0 Then NumberToArabicText = "صفر" Exit Function End If Dim HundredsDigit As Integer Dim TensDigit As Integer Dim OnesDigit As Integer HundredsDigit = (TheNumber Mod 1000) \ 100 TensDigit = (TheNumber Mod 100) \ 10 OnesDigit = TheNumber Mod 10 If HundredsDigit >= 0 And HundredsDigit <= 9 Then Hundreds = MyArray1(HundredsDigit) Else Hundreds = "" End If If TensDigit = 1 Then Select Case OnesDigit Case 0: Tens = "عشرة" Case 1: Tens = "إحدى عشرة" Case 2: Tens = "إثنتا عشرة" Case Else: Tens = MyArray3(OnesDigit) & MyArray2(TensDigit) End Select Else Ones = MyArray3(OnesDigit) Tens = MyArray2(TensDigit) If Ones <> "" And Tens <> "" Then Tens = Ones & AndConnector & Tens Else Tens = Ones & Tens End If End If If Hundreds <> "" And Tens <> "" Then Result = Hundreds & AndConnector & Tens Else Result = Hundreds & Tens End If If TheNumber > 999 Then Dim Thousands As Long Dim Remainder As Long Thousands = TheNumber \ 1000 Remainder = TheNumber Mod 1000 Dim ThousandsText As String ThousandsText = NumberToArabicText(Thousands) If Thousands = 1 Then ThousandsText = "ألف" ElseIf Thousands = 2 Then ThousandsText = "ألفين" ElseIf Thousands >= 3 And Thousands <= 10 Then ThousandsText = NumberToArabicText(Thousands) & " آلاف" Else ThousandsText = NumberToArabicText(Thousands) & " ألف" End If If Remainder > 0 Then Result = ThousandsText & AndConnector & NumberToArabicText(Remainder) Else Result = ThousandsText End If End If NumberToArabicText = Result End Function ولتسهيل فهم الموضوع عند الإستدعاءات المختلفة ، تم انشاء نموذج بسيط يضم 22 زر ولكل زر طريقة استدعاء مختلفة تسهيلاً للمستخدم كي تتوضح له آلية العمل . كما تم اضافة 3 مربعات نص كل منها يعرض التفقيط بشكل مختلف . ♻ المرفق :- Date Duration to Arabic Words.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 اليوم سأقدم لكم فكرة لإنشاء ساعة رقمية مشابهة لألواح الإعلانات المضيئة ، ولكن بطريقة و نكهة مختلفتين كالعادة ▫▪◽◾◻◼ . صورة للنتيجة .. المرفق مفتوح المصدر دون إطالة BackLight2.accdb

وعليكم السلام ورحمة الله نعالى وبركاته دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019 يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال =IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو =IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز")) يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS في Module قم بلصق الكود التالي Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية =IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز") في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى Excel 2021 رابط التحميل https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file حيث تكون هذه الدالة مدعومة بشكل كامل بالتوفيق............. TEST-IFS.xlsb

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip

السلام عليكم 🙂 رجاء الرجوع الى النسخة الاولى من هذا الموضوع لفهم تفاصيل الكود . عرضت عليكم جميع التفاصيل في عمل حدث الـ Data Macro ، فكان على المبرمج ان يكتب جميع خطوات الكود لكل حقل ولكل حدث ، يدويا !! وهنا اعطيكم طريقة طريقة عمله برمجيا (يعني المبرمج ما عنده عذر من الان ان لا يستخدم هذه الاداة في برامجه 🙂 ). هذه واجهة وكائنات البرنامج: . 9. نقوم بالنقر على الزر رقم 9 مرة واحدة فقط ، فيقوم بنسخ الجدول جدول tbl_x_AuditTrail فارغ ، والوحدة النمطية mod_UserName_PcName ، الى قاعدة البيانات التي تم اختيارها في رقم 3 ، 1. جدول tbl_x_AuditTrail فارغ ، وسيتم عمل نسخة منه ومن الوحدة النمطية mod_UserName_PcName عند النقر على الزر رقم 9 ، الى قاعدة البيانات التي تم اختيارها في رقم 3 ، 2. يجب اختيار قاعدة البيانات التي تريد عمل احداث الجداول عن طريق الـ Data Macro فيها ، وسيتم ظهور اسم قاعدة البيانات في الرقم 3 ، وفي نفس الوقت سيتم ظهور اسماء جداولها في الرقم 4 ، 4. اختار الجدول الذي تريد عمل الاحداث عليه ، ومنها ستظهر اسماء حقوله في الرقم 5 ، 5. تختار اسماء الحقول التي تريد ان تتابع متغيراتها (وهو اساس هذا البرنامج) ، وتستطيع اختيار جميع الحقول لهذا الحدث بالنقر على الزر 6 : 5.1 لتسجيل وحفظ متغير الحقل عند اضافة سجل جديد (الحاق سجل جديد) ، 5.2 لتسجيل وحفظ متغير الحقل عند عمل تغيير على قيمة الحقل (بعد تحديث الحقل) ، 5.3 لتسجيل وحفظ متغير الحقل عند حذف السجل ، 7. يجب اختيار حقل المفتاح الاساسي في الجدول ، 8. عند الانتهاء من الاختيارات ، ننقر على الزر رقم 8 ، فيقوم بعمل الـ Data Macro لجميع الحقول في الجدول الذي تم اختياره ، وستاتيك رسالة تؤكد انتهاء العمل. وللعمل على حقول جدول آخر ، ابدأ من الرقم 4 اعلاه مرة اخرى. هنا سأعطي مثال عن طريقة العمل ، والنتائج: هذه قاعدة البيانات التي ساعمل عليها ، ونرى انه لا يوجد بها الجدول tbl_x_AuditTrail فارغ ، ولا الوحدة النمطية mod_UserName_PcName ، ولا توجد اي احداث في المربع الاحمر : . خطوات العمل: . والنتيجة في قاعدة البيانات الاخرى: . والان لنرى عندما نعمل اي تغيير في المتغيرات: . هنا نرى ان الاحداث الثلاثة موجودة في هذا الجدول ، وطبعا في الجدول الآخر كذلك : . وهنا نقارن النتائج . جعفر Make_AuditTrail_XML_02.zip

::بسم الله نبدأ:: السلام عليكم ورحمة الله وبركاته اخوتي الكرام كل عام وانتم بخير اليوم وكما هو موضع من عنوان الموضوع موضوعنا عن ربط برنامج الاكسيس بصفحات الويب وهنا اخص لغة ال PHP كان فى سائل عن امكانية ربط برنامج الاكسيس بالنت علشان يسمح للمرضي بتحميل التقارير الخاصه بهم ورديت عليه تقريبا ان الموضوع صعب لكن اليوم اقدم لكم طريقه اتمني ان تكون سهله وواضحه واعذروني على المقدمة الطويله ورقاقة الكلمات نبدأ اولا بالادوات الازم توفرها:- 1- XAMPP يمكن تحميله من هنا 2- Connector/ODBC MYSQL يمكن تحميله من هنا ويفضل تنزيل النسخه 8.0.31 انا عن نفسي شغال بالاصدار 8.0.31 (وشغال تمام) وممكن تحمله من هنا للنسخه 32بت ومن هنا للنسخه 64بت 3- ActiveX WebBrowser control (antview) يمكن تحميل هذه الاداة من هنا او رابط مباشرة من هنا 4- PHP File's & Access File هنا يمكن تحميل الملفات التى قمت بالعمل عليها :: نبدأ بتسطيب برنامج XAMPP :: وهو المحاكي الذى سيعمل فيه بيئة ملفات ال php طبعا المفترض ان هناك دومين موجود بالفعل واستضافة والذى سيتم تنصيب الخدمه عليه وعن طريقها سيكون متاح للمريض ان يحمل تقريره لكن الموضوع هنا للتعليم فنبدأ اولا بتسطيب البرنامج ليس بالامر الصعب بل سهل جدا وحتى لا يطول الشرح اذا واجهتك مشكلة فى تسطيب البرنامج يمكن كتابة وصور المشكله او البحث فى اليوتيوب وهتلاقى الحل المناسب (لكن عموما كل ال هتعمله اوافق والتالى التالى شكرا) بعد تنصيب البرنامج وهذه واجهته ويجب يكونو هكذا هنضغط على مفتاح Explorer او نذهب الى المسار هذا C:\xampp او حسب المكان الذى سطبت البرنامج فيه هندخل على المجلد htdocs وهنا هننسخ مشروعنا ويفضل متلعبش فى الملفات التى داخل المجلد htdocs غير لو انت فاهم بتعمل ايه نرجع لموضوعنا هننسخ الملف ال اسمه LAB وهنضعه فى المجلد htdocs هنفتح المتصفح وندخل على الرابط التالى http://localhost/phpmyadmin/ وهنبدأ بانشاء قاعدة بيانات جديده وهنسميها db_lab بعدها هندخل على القاعدة التى تم انشاءها وهنعمل عمليت استيراد هنضغط على استعراض وهنروح للمسار C:\xampp\htdocs\LAB هنلاقى فى ملف نفس اسم قاعدة البيانات وبعدها هننزل تحت وهنضغط على import وبهذا نكون قد انتهينا من رفع القاعدة نذهب الى هذا الرابط ونتحقق ان كل شئ تمام http://localhost/lab/ لو ظهر لك هذا الشاشة يبقي امورك فى التمام والحمد لله اذا لا بيكون فى خطأ حصل نبدأ نسطب برنامج Connector/ODBC MYSQL (( لا يحتاج الى شرح الامر بسيط وسهل وايضا حتى لا يطول الموضوع )) من هنا هنحتاج الى تركيز الامور بسيطه لكن لازم تتعمل صح هنروح للكنترول بنل لو انت شغال على وندوز 11 لو انت شغال على وندوز 10 هنا هتختار واحد منهم حسب اصدار الاوفيس عندك 32بت ولا 64 بتحميل انا هنا اصدار 64 بت هنكتب الاعدادات كما فى الصورة بالظبط لو انت حاطط كلمة سر لل phpmyadmin هتحطها وتضغط اوك بعد ما تختار القاعده الخاصه بك وبكده نكون انتهينا من هذا الجذء نبدأ تثبيت برنامج ActiveX WebBrowser control (antview) وده ال هيكون مسؤول عن استعراض صفحات الويب داخل الاكسيس وهي اداة ممتاذه عيبه تقريبا حسب الموقع انها مش مجانيه لو فى اى احد عنده طريقة نستخدم خاصية webview2 هي موجوده فى اوفيس 365 تقريبا وحسب ما سمعت انها بتنزل متضمنه لكن فى الاصدارات ال معانا مش موجوده او اى اداة اخري تكون مجانيه 100% يبقي تمام تثبيت البرنامج لا يحتاج شرح ^_^ نرجع لملف التطبيق الاكسيس ^_^ ونفتح البرنامج عادي بعد ما تم تثبيت كل الادوات السابق ذكرها وبرنامج الاكسيس هتلاقيه فى مجلد اسمه APP ممكن تنقله لاى مكان عادي وللعلم تم اضافة مكتبة واكود QR Code اخذتها من موضوع استاذى الاستاذ @ابو جودي فى موضوع الفاتورة الالكترونية 🤲 ربنا يبارك فيه وفى جميع اساتذتى هنا 🤲 نفتح ملف الاكسيس ونتأكد ان جميع المكتبات تعمل وليس هناك اى مكتبه مفقوده نركز على الصوره التالية هنتحقق من التالى ان الجداول متصله والمطلوب انك تفتح اى جدول للتأكد انه يعمل الاتصال جيدا هنفتح النماذج اول نموذج معانا FrmGenerator_User هنا انت لو عاوز تعمل اسم مستخدم وكلمة مرور ال هيدخل بيها المريض عندك كما هو موضح من الصورة حلين اما الاكسيس يعمل اسم مستخدم وكلمة سر عشوائية (1) او انت تعمل للمريض اسم مستخدم وكلمة سر يديوية (2) بعد ما تضيف حساب المريض هيكون هنا عندك القدرة على اضافة التقارير للمريض تابع الصور التالية يمكنك تحديد اكثر من ملف هنا فى الكود يسمح لك باستعراض ملفات الصور وال pdf بعد رفعها لو هناك اى ملاحظات تريد ان تسجلها يمكن هذا هتكتب الملاحظه وتعمل حفظ 😁 التالى لو انت عاوز تحول كلمة سر الى كود هاش هذا لو فرضا انك عاوز تغير كلمة السر لحساب ما وللعلم التشفير فى نظام ال PHP تشفير بالهاش هو تشفير فى اتجاه واحد يعنى يمكن عمل مطابقة لكلمة السر مع الهاش لكن متقدرش تحول الهاش الى كلمة سر طبعا ده علشان الحماية وده سياسة التشفير فى PHP والله اعلم او لو عاوز تتحقق من كلمة السر (يعني معاك كلمة السر والهاش وعاوز تتحقق انهم مطابقين ) هتضغط على التحقق وهو هيتحققلك بعد ما تم اضافة حساب للمريض عن طريق نموذج انشاء الحسابات وتم رفع الملفات للمريض هنروح على نموذج انشاء ال QR Code هنختار اسم حساب المريض من القائمة (قائمة المرضي) ونضغط على تصدير رمز ال QR اعتقد اني شرحت كل الامور واذا كان هناك اى مشكلة اقدر احلها لا تتردد فى الاستفسار وهتلاقى الجميع هنا بيسعدك بعض الملاحظات الواجب التنبيه لها يجب ان تغير عنوان الموقع اما للدومين اذا كان لديك دومين مع تعديل مسار البرنامج اذا لزم الام او كتابة عنوان الكمبيوتر الخاص بك اذا كنت تريد التجربه علشان لما تقراء كود QR يدخلك على الصفحه بطريقة صحيحة طريقة التعديل :- هتروح على كود نموذج انشاء كود QR وتعدل على العنوان بدل 127.0.0.1 وكل عام وانتم بخير وختاما نسألكم الدعاء لوالدتي الله يرحمها والشفاء لوالدي ربنا يبارك فى صحته ولا تنسونا من صالح دعواتكم الطيبة

Ferry Login v1- free.rar

وعليكم السلام ورحمة الله تعالى وبركاته يجب أولا التأكد من عدم تعطيل وحدات الماكرو بسبب أمان الملفات أغلق الملف ثم انقر بزر الماوس الأيمن على خصائص <------ إلغاء الحظر (Unblock) أعد فتح الملف وحاول تشغيل الماكرو التالي Sub OECUE1() Dim WS As Worksheet Dim début As Integer, fin As Integer Set WS = Sheets("haneen") If Not IsNumeric(WS.[H2].Value) Or Not IsNumeric(WS.[U2].Value) Then Exit Sub début = WS.[H2].Value: fin = WS.[U2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب في تنفيذ الطباعة؟", vbYesNo + vbExclamation, "التأكيد") = vbNo Then Exit Sub Application.ScreenUpdating = False Do While début <= fin WS.PrintOut Copies:=1, Collate:=True If début < fin Then WS.[H2].Value = début + 1 début = début + 1 Loop Application.ScreenUpdating = True End Sub الطباعة.rar

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم تم التعديل

مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 3 ، وزر واحد فقط وظائفهم كالآتي :- cmbTable1 : التعرف على أسماء الجداول في قاعدة البيانات ، وهنا سيكون الجدول الأول . cmbTable2 : التعرف على أسماء الجداول في قاعدة البيانات باستثناء الجدول الذي تم اختياره في cmbTable1 ؛ والهدف هو عمل مقارنة بين جدولين وليس نفس الجدول . cmbPrimaryField : التعرف على أسماء الحقول في الجدول الأول ، ثم يتم اختيار الحقل المشترك أو المفتاح الأساسي من طرف المستخدم . btnExecute : منفّـذ العملية . ⭐ الأحداث والأكواد لكل جزء و عنصر في البرنامج :- في حدث عند التحميل للنموذج ، تم وضع الكود التالي لجلب أسماء الجداول إلى الكومبوبوكس ( cmbTable1 و cmbTable2 ) ، وطبعاً سيتم استثناء جداول النظام والجدول DifferencesTable الذي سيتم إدراج التغييرات فيه ( والذي سيتم انشائه بشكل ديناميكي في قاعدة البيانات عند المستخدم عند عدم وجوده ) . أي أنه وللإستفادة من البرنامج ما عليك إلا نسخ النموذج فقط الى مشروعك . Private Sub Form_Load() Me.cmbTable2.Enabled = False Me.cmbPrimaryField.Enabled = False Dim tdf As DAO.TableDef Me.cmbTable1.RowSource = "" Me.cmbTable2.RowSource = "" For Each tdf In CurrentDb.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" Then Me.cmbTable1.AddItem tdf.Name 'Me.cmbTable2.AddItem tdf.Name End If Next tdf End Sub في حدث بعد التحديث للكومبوبوكس cmbTable1 ، سيتم إدراج أسماء الجداول المتبقية كما ذكرت سابقاً في الكومبوبوكس cmbTable2 باستثناء ما تم اختياره في الجدول cmbTable1 :- Private Sub cmbTable1_AfterUpdate() Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Me.cmbPrimaryField.RowSource = "" Set db = CurrentDb Set tdf = db.TableDefs(Me.cmbTable1.Value) For Each fld In tdf.Fields Me.cmbPrimaryField.AddItem fld.Name Next fld Me.cmbTable2.RowSource = "" For Each tdf In db.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" And tdf.Name <> Me.cmbTable1.Value Then Me.cmbTable2.AddItem tdf.Name End If Next tdf Me.cmbTable2.Enabled = True Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub في حدث عند النقر على الزر btnExecute ، سيتم تنفيذ الكود التالي :- Private Sub btnExecute_Click() Dim db As DAO.Database Dim rsOld As DAO.Recordset Dim rsNew As DAO.Recordset Dim rsDifferences As DAO.Recordset Dim fld As DAO.Field Dim recordFound As Boolean Dim commonFields As Collection Dim fieldName As Variant Dim primaryField As String Dim table1 As String Dim table2 As String If IsNull(Me.cmbTable1) Then MsgBox "قم باختيار الجدول الأول", vbCritical, "" Me.cmbTable1.SetFocus Exit Sub ElseIf IsNull(Me.cmbTable2) Then MsgBox "قم باختيار الجدول الثاني", vbCritical, "" Me.cmbTable2.SetFocus Exit Sub ElseIf IsNull(Me.cmbPrimaryField) Then MsgBox "قم باختيار الحقل الأساسي", vbCritical, "" Me.cmbPrimaryField.SetFocus Exit Sub Else table1 = Me.cmbTable1.Value table2 = Me.cmbTable2.Value primaryField = Me.cmbPrimaryField.Value If IsNull(table1) Or IsNull(table2) Or IsNull(primaryField) Then MsgBox "Please select both tables and the primary field." Exit Sub End If Set db = CurrentDb If Not TableExists("DifferencesTable") Then CreateDifferencesTable db End If Set rsOld = db.OpenRecordset(table1) Set rsNew = db.OpenRecordset(table2) Set rsDifferences = db.OpenRecordset("DifferencesTable", dbOpenDynaset) DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM DifferencesTable;" DoCmd.SetWarnings True Set commonFields = New Collection For Each fld In rsOld.Fields On Error Resume Next If Not IsNull(rsNew.Fields(fld.Name).Name) Then If fld.Name <> primaryField Then commonFields.Add fld.Name, fld.Name End If End If On Error GoTo 0 Next fld Do While Not rsOld.EOF recordFound = False rsNew.MoveFirst Do While Not rsNew.EOF If rsOld(primaryField) = rsNew(primaryField) Then recordFound = True For Each fieldName In commonFields If Nz(rsOld(fieldName), "") <> Nz(rsNew(fieldName), "") Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Modification" rsDifferences("FieldName") = fieldName rsDifferences("OldValue") = rsOld(fieldName) rsDifferences("NewValue") = rsNew(fieldName) rsDifferences.Update End If Next fieldName Exit Do End If rsNew.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Deletion" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = "عملية حذف" rsDifferences("NewValue") = Null rsDifferences.Update End If rsOld.MoveNext Loop rsNew.MoveFirst Do While Not rsNew.EOF recordFound = False rsOld.MoveFirst Do While Not rsOld.EOF If rsNew(primaryField) = rsOld(primaryField) Then recordFound = True Exit Do End If rsOld.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsNew(primaryField) rsDifferences("ChangeType") = "Addition" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = Null rsDifferences("NewValue") = "عملية إضافة" rsDifferences.Update End If rsNew.MoveNext Loop rsOld.Close rsNew.Close rsDifferences.Close Set rsOld = Nothing Set rsNew = Nothing Set rsDifferences = Nothing Set db = Nothing End If CreatePivotQuery table1, table2 MsgBox "تمت عملية المقارنة في الجدولين ، وسيتم فتح الاستعلام بالنتائج", vbInformation, "" DoCmd.OpenQuery "Foksh", acViewNormal End Sub الكود يقوم بتنفيذ عملية مقارنة بين بيانات الجدولين ( من خلال اختيار الجدول الأول والجدول الثاني كما ذكرت سابقاً ) في أي قاعدة بيانات للمستخدم . وفيما يلي شرح مبسط للخطوات الرئيسية التي ينفذها هذا الكود ( للفائدة ):- التحقق من القيم في الكومبوبوكسات الثلاثة يتم التحقق مما إذا كان المستخدم قد اختار الجداول الأساسية ( الجدول الأول و الجدول الثاني ) وحقل المفتاح الأساسي للمقارنة . فإذا كانت أي من هذه المدخلات مفقودة أو لم يتم اختياره ، يعرض الكود رسالة تحذير بوجوب اختيار الجدول أو المفتاح الأساسي وبالتالي يوقف العملية . تحضير البيانات يتم فتح السجلات من الجداول المختارة (الجدول الأول والجدول الثاني) وإنشاء سجل جديد في جدول DifferencesTable لتخزين الفروقات والتغيرات . مقارنة البيانات سيقوم الكود بمقارنة السجلات في الجدولين اللذين تم اختيارهم سابقاً . فإذا كانت السجلات متطابقة في كلا الجدولين ، يتم مقارنة الحقول المشتركة فقط - أي الحقول الموجودة و المتشابهة بالإسم في الجدولين (باستثناء الحقل الأساسي) لتحديد التغييرات . فإذا كانت السجلات مفقودة في أحد الجدولين ( أي تم الحذف أو الإضافة في أي من الجدولين ) ، يتم تحديد نوع التغيير كـ ( عملية حذف ) أو ( عملية إضافة ). إدخال النتائج وإضافتها للجدول DifferencesTable يتم إضافة البيانات الناتجة عن التغييرات ( مثل القيمة القديمة والجديدة ) في جدول DifferencesTable ، مع تسجيل نوع التغيير ( إضافة، حذف، أو تعديل ) . إنشاء استعلام PIVOT أو ما يعرف بالإستعلام Crosstab بعد الانتهاء من المقارنة في الخطوة السابقة ، يتم إنشاء استعلام من نوع Pivot أو Crosstab ( استعلام جدولي كما يسمى في آكسس الواجهة العربية ) ؛ وهو يستخدم لتحويل البيانات من شكل الصفوف إلى شكل الأعمدة ( إن صح التعبير ) ، مما يجعل هذه البيانات أكثر تنظيماً وأسهل في التحليل و القراءةً . والهدف منه هو عرض التغييرات بطريقة منظمة باستخدام الحقول المشتركة بين الجدولين . فتح الاستعلام في نهاية الكود ، يتم فتح الاستعلام الذي يعرض الفروقات والتغيرات بين الجدولين بشكل عادي . ⭐ وظائف أخرى يتم استدعائها لأنشاء الجدول DifferencesTable بعد التأكد من وجوده أو لا . وأخرى لإنشاء الإستعلام الذي يحتوي التغيرات التي تم تعقبها :- وظيفة التأكد من وجود الجدول أو لا :- Function TableExists(tableName As String) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef TableExists = False Set db = CurrentDb For Each tdf In db.TableDefs If tdf.Name = tableName Then TableExists = True Exit For End If Next tdf End Function في حال عدم وجود الجدول DifferencesTable ، سيتم استدعاء هذا الـ Sub لإنشائه مع الحقول التي سنحتاجها لعرض البيانات المختلفة في الجدولين :- Sub CreateDifferencesTable(db As DAO.Database) Dim tdf As DAO.TableDef Set tdf = db.CreateTableDef("DifferencesTable") tdf.Fields.Append tdf.CreateField("ID", dbLong) tdf.Fields.Append tdf.CreateField("ChangeType", dbText, 50) tdf.Fields.Append tdf.CreateField("FieldName", dbText, 50) tdf.Fields.Append tdf.CreateField("OldValue", dbMemo) tdf.Fields.Append tdf.CreateField("NewValue", dbMemo) db.TableDefs.Append tdf End Sub بعد تتبع التغيرات والفروقات ، سيتم انشاء استعلام باسم Foksh ، لعرض التغيرات التي تم التعرف عليها :- Sub CreatePivotQuery(table1 As String, table2 As String) Dim queryDef As DAO.queryDef Dim sql As String sql = "TRANSFORM First('" & table1 & " ' & [OldValue] & ' - ' & '" & table2 & " ' & [newvalue]) AS dd " & _ "SELECT DifferencesTable.ID " & _ "FROM DifferencesTable " & _ "GROUP BY DifferencesTable.ID " & _ "PIVOT DifferencesTable.FieldName;" On Error Resume Next CurrentDb.QueryDefs.Delete "Foksh" On Error GoTo 0 Set queryDef = CurrentDb.CreateQueryDef("Foksh", sql) Set queryDef = Nothing End Sub وأخيراً وليس آخراً :- UnMatched.accdb وهذه صورة للبرنامج :-

السلام عليكم ورحمه الله وبركاته اضع بين ايديكم هديه متواضعه صدقه جاريه على روح والدى ( برجاء قراءه الفاتحه ) الانتهاء من برنامج اداره وتوزيع النوبتجيات والاجازات ينفع لكافه الانشطه المدنيه العسكريه التى تعتمد على نوبتجيات او ورديات - متابعه الاجازات بدقه ( يحسبلك المتبقي من العرضيات والسنويات وما الي ذلك ) ورفض تسجيلها فى حاله كون الموظف نوبتجي - توزيع النوبتجيات اتوماتيك لكل القوه حسب النوبتجيه المكلف بها ( استثناء الاجازات من التوزيع ودرجهم فالدور بمجرد انتهاء الاجازات ) - عرض تقارير مفصله ( سواء اجازات - نوبتجيات لكل موظف ) - حجم البرنامج لا يتعدي ١٠ ميجا ويعمل علي كافه انظمه اوفيس بدايه من اوفيس ٢٠١٠ - يضع التقارير والنوبتجيات تلقائي في مجلدات بجانب البرنامج ( تقارير شهريه - نوبتجيات موظفبن - اجازات موظفين - نوبتجيات يوميه ) - يصلح لكافه الاغراض المدنيه التي تعمل علي ورديات مختلفه أو توزيع عماله علي اماكن عمل ومواقع مختلفه ( سواء شركات أمن - شركات نظافه - خدمات بتروليه - مصانع ...الخ ) -😎😎 البرنامج مجاني بكل اكواده وتصميماته ومتاح للتعديل صدقه جاريه على روح والدى الله يرحمه فضلا وليس امرا الدعاء له كلمه المرور 1510 ملحوظه تم الاستعانه بتصميم بعض قواعد البيانات ( تصاميم فقط ) لكن كل اكواد البرنامج هي من تصميمي إن شاءالله نوبتجيات.rar

بناءً على إقتراح أستاذنا @Moosak تم إضافة ميزة " التسمية التوضيحية - Caption " للحقول . تم إضافة ميزة " التعرف على حقل الترقيم التلقائي " عند وجوده والتخيير بين جعله مفتاح أساسي أو لا . في حال عدم وجود حقل ترقيم تلقائي ، سيتم التنبيه بعدم وجوده وإنشاء حقل جديد ID = AutoNumber ؛ والتخيير أيضاً بإنشائه أو لا . وعند إنشائه سيكون له خاصية مفتاح اساسي PrimaryKey . 💡ملاحظة : في التعديل القادم سيتم إتاحة الفرصة للمستخدم بالتعديل على الحقول قبل إنشاء الجدول كخطوة أخيرة 🤗 TBL Maker.accdb

Gemini API.accdb

السلام عليكم 🙂 هذا الموقع يعطي ترتيب أكثر قواعد بيانات العالم استخداما: https://db-engines.com/en/ranking/relational+dbms والترتيب متغير شهريا ، ففي هذا الشهر: 6/2024 ، يكون ترتيب الاكسس رقم 8 عالميا : . واليكم طريقة تقييمهم للترتيب من: https://db-engines.com/en/ranking_definition وهنا تمت ترجمته آليا الى العربية: جعفر

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة جرب هدا هل يناسيك Option Explicit Public Sub Add_CheckBoxes() Dim tbl As Long, cb As OLEObject, OnRng As Range, ky As Variant Dim dataArray() As String, Search As String, n As Boolean Dim i As Long, lastRow As Long, col As Long, lastCol As Long Dim kys() As String Dim CrWS As Worksheet: Set CrWS = Sheets("MenuF") Dim dest As Worksheet: Set dest = Sheets("main sheet") Search = Trim(CrWS.Range("B1").Value) If Search = "" Then: MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row n = False For i = 2 To lastRow If Trim(dest.Cells(i, 1).Value) = Search Then tbl = i n = True Exit For End If Next i If Not n Then: MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation: Exit Sub lastCol = dest.Cells(tbl, Columns.Count).End(xlToLeft).Column ReDim dataArray(1 To lastCol - 1) For col = 2 To lastCol dataArray(col - 1) = Trim(dest.Cells(tbl, col).Value) Next col For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then cb.Object.Value = False Next cb For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "،", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb End If Next i Next ky End If Next OnRng End Sub Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function Private Function CompareValues(val1 As String, val2 As String) As Boolean CompareValues = (InStr(1, val1, val2, vbTextCompare) > 0 Or InStr(1, val2, val1, vbTextCompare) > 0) End Function لتلوين القيم CrWS.Range("A3:I7").Font.Color = vbBlack For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "?", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb OnRng.Font.Color = vbRed End If Next i Next ky يمكنك إختيار ما يناسبك فورمة - V4.xlsb

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

وعليكم السلام ورحمة الله وبركاته 🙂 عملت شيء مشابه لهذا سابقا .. فقط يمكن تعديله ليتوافق مع الحاجة 🙂 ‏‏Meter -Moosak _ Final.accdb

مشاركة مع اخي محمد يمكن الاستعانة بوسيط لإخراج الصور على النحو التالي : افتح البرنامج على عرض التصميم في جزء التنقل : - حدد النموذج الذي يحتوي على صورة خلفية أو تنسيق تلقائي تريده - انقر بزر الماوس الأيمن على النموذج في جزء التنقل وحدد تصدير >> XML في الصفحة الأولى من المعالج ، حدد مكان الحفظ انقر التالي او موافق سيظهر لك مربع حوار صغير به ثلاثة مربعات اختيار قم باختيار الخيار الأول (البيانات) والخيار الثالث (العرض التقديمي) ثم اضغط موافق انقر فوق الزر "إغلاق" في الصفحة الأخيرة من المعالج بعد اكتمال عملية التصدير اذهب الى مكان الحفظ ستجد جميع صورك في مجلد Images

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) هذه المرة دعوة لتجربة لعبة المتاهة Maze لأول مرة من خلال آكسيس ميزات اللعبة :- التحكم الكامل من خلال الأسهم في لوحة المفاتيح . تجميع النقاط كلما التهمت الشخصية عدداً أكبر من ( ) . تخسر إذا لامست هذا الكائن في اللعبة ( ) عند طلب المساعدة باستخدام ( ) فإنه سيتم خصم 10 نقاط من رصيد النقاط التي قمت بتجميعها . اللعبة في إصدارها الأول حالياً وسيكون قريباً الكثير من المستويات في اللعب ، وهذه فقط دعوة لتجربتها وإفادتي بآرائكم حول تطويرها وتحديثها وأترككم مع ملف التحميل : Maze Game.zip

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

وعليكم السلام ورحمة الله تعالى وبركاته ضع الكود التالي في Module Sub HideRowsWith_Zero() Dim Sh As Worksheet Dim i As Long, lastRow As Long Set Sh = ThisWorkbook.Sheets("تفاصيل") lastRow = Sh.Columns("A:C").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 4 To lastRow If Sh.Cells(i, 2).Value = 0 And Sh.Cells(i, 3).Value = 0 Then Sh.Rows(i).Hidden = True Else Sh.Rows(i).Hidden = False End If Next i End Sub وفي حدث ورقة تفاصيل Private Sub Worksheet_Activate() HideRowsWith_Zero End Sub اخفاء الصفوف.xlsb

السلام عليكم ورحمة الله تعالى وبركاته الموضوع اخذ وقت وجهد شديدين ان شاء الله ينال رضاكم واقدمه ابتغاء وجه الله تعالى ليكون هدية قمية فى مكتباتكم وقواعد بياناتكم فى اعمالكم ان شاء الله اولا وبادئ ذى بدئ لابد أن أتقدم باخالص الشكر والتقدير والعرفان بالجميل لمن تحملوا إثقالى عليهم مرارا وتكرار دون كلل أو ملل حتى يخرج هذا العمل فى أبهى صورة وبهذا الشكل معلمى القدير وأستاذى الجليل و والدى الحبيب الأستاذ @ابوخليل أول يد امتدت إلى فى هذا الصرح الشامخ فتحمل جهلى دائما بحلم ودوما يصحح لى أخطائى بعلم فجزاه الله تعالى عنى وعن كل طلاب العلم كل الخير وحتى لا أضيع فضل أحد الأساتذة العظماء أو ينسينى الشيطان ذكر ـى من العظماء الكرام الذين نتعلم منهم جمبعا فى هذا الصرح الشامخ الذى هو بمثابة ينابيع العلوم والمعرفة وبساتين الأفكار التى نطوف بهم فنرتشف من كل ينبوع قطرة ونأخذ من كل بستان زهرة جزا الله كل أصحاب الفضل علينا والذين نتعلم على اياديهم المباركة وشكر الله لكم حسن صنيعكم معنا و تحملكم لنا . صاحب المكتبة العامرة سيادة المستشار المؤتمن ... والله اشتقنا الاستاذ @Moosak اقول له جرب وقول لى رايك يجرب ويطلع عينى بجد تعب معايا بس عرفت من تجاربه حجات مكنتش اعرفها والله على سبيل المثال المنازل العشرية المختلفة للعملات والاسماء الذكورية والانثوية بصراحة لم انتبه اليها كان كل همى الكود وترتيب الافكار لكن نعمل ايه ادى اخرة اللى يصاحب اخ بالشكل ده يطلع عينه🤣 أدامكم الله أرواح طيبة تسكن القلوب .. ووجوه باسمة ترتاح لها العيون .. وأنفس مطمئنة دائما وابدا تمتلك النفوس .. وأسأله عز وجل أن يعطيكم من عطــاياه ويمنحكم عفوه ورضاه ويغفر لكم من عمركم ما مضى ويقدر لكم الخير فيما أتى .. وأن يجعل السعادة رفيقتكم في الدنيا والآخره.. اللهم آمين ------------------------------------------- الموضوع متعب جدا الاكواد كثيرة ومن أجل ذلم يمكن النقاش فيها ان اردتم وسوف يتم الرد على قدر السؤال لان فعلا الاكواد ليست قليلة وكم الافكار بها ليس بالهين ولكن ان شاء الله سوف تتناولها سريعا ونأخذ عنها فكرة . اولا الاكواد داخل الوحدة النمطية اجمالا Option Compare Database Option Explicit '********************************************************************** ' Function: ConvertCurrencyToWords ' Purpose: Converts a numeric value to its word representation based on the specified options. ' Inputs: ' Number - The numeric value to be converted (Variant). ' Optional CurrencyType - A string specifying the type of currency (default is ""). ' Optional language - The language for the conversion, e.g., "ar" for Arabic or "en" for English (default is "ar"). ' Optional ShowExtras - A Boolean flag indicating whether to include additional details (default is True). ' Returns: String - The numeric value converted to words, based on the provided parameters. ' Notes: ' - The function handles both integer and fractional parts of the number. ' - The `CurrencyType` parameter can be used to specify different types of currencies for more precise conversion. ' - The `language` parameter controls the language in which the number is converted to words. ' - The `ShowExtras` parameter determines if additional information such as currency symbols or other text should be included. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** ' Example usages: ' 1. ConvertCurrencyToWords(Number) ' - Converts the provided numeric value to Currency words in the default language (Arabic) with additional details. ' - Example: ConvertNumberToWords(123.45) . ' 2. ConvertCurrencyToWords(Number, "Currency Type") ' - Converts the provided numeric value to words in the default language (Arabic) and specifies the currency type as USD. ' - Example: ConvertCurrencyToWords(123.45, "Currency Type"). ' 3. ConvertCurrencyToWords(Number, "", "en") ' - Converts the provided numeric value to words in English and includes additional Currency details. ' - Example: ConvertCurrencyToWords(123.45, "", "en"). ' 4. ConvertNumberToWords(Number) ' - Converts the provided numeric value to words in Arabic but excludes additional Currency details. ' - Example: ConvertCurrencyToWords(123.45,"en"). ' 5. ConvertNumberToWords(Number, "", "en", False) ' - Converts the provided numeric value to words in English but excludes additional Currency details. ' - Example: ConvertCurrencyToWords(123.45, "", "en", False) . ' This function is versatile and can be used to convert numbers to words in various languages and formats, depending on the parameters provided. '********************************************************************** '********************************************************************** ' Variable Declarations '********************************************************************** ' Currency Information in Arabic ' Represents the singular name of the currency. Dim CurrencyNameSingular As String ' Represents the dual form of the currency name. Dim CurrencyNameDual As String ' Represents the plural form of the currency name. Dim CurrencyNamePlural As String ' Represents the accusative form of the currency name. Dim CurrencyNameAccusative As String ' Represents the singular form of the fractional unit (e.g., piastre). Dim FractionalUnitSingular As String ' Represents the dual form of the fractional unit. Dim FractionalUnitDual As String ' Represents the plural form of the fractional unit. Dim FractionalUnitPlural As String ' Represents the accusative form of the fractional unit. Dim FractionalUnitAccusative As String ' Currency Information in Other Language ' Represents the singular name of the currency in another language (e.g., English). Dim CurrencyNameSingularOtherLang As String ' Represents the dual form of the currency name in another language. Dim CurrencyNameDualOtherLang As String ' Represents the plural form of the currency name in another language. Dim CurrencyNamePluralOtherLang As String ' Represents the accusative form of the currency name in another language. Dim CurrencyNameAccusativeOtherLang As String ' Represents the singular form of the fractional unit in another language. Dim FractionalUnitSingularOtherLang As String ' Represents the dual form of the fractional unit in another language. Dim FractionalUnitDualOtherLang As String ' Represents the plural form of the fractional unit in another language. Dim FractionalUnitPluralOtherLang As String ' Represents the accusative form of the fractional unit in another language. Dim FractionalUnitAccusativeOtherLang As String ' Represents the base value of the currency. Dim CurrencyBaseValue As Integer ' Represents the base value of the fractional unit. Dim FractionalUnitBaseValue As Integer ' Represents the ISO code for the currency. Dim CurrencyISOCode As String ' Represents the number of decimal places for the currency. Dim NumberOfDecimalPlaces As Integer ' Indicates whether the currency is considered feminine. Dim isCurrencyFeminine As Boolean '********************************************************************** ' Function: CurrencyYouWantToBeActive ' Purpose: Returns the name of the currency that should be set as active. ' Inputs: None. ' Outputs: None. ' Returns: String - The name of the active currency in Arabic (encoded as ASCII characters). ' Notes: - The returned string is encoded using ASCII character codes to represent Arabic text. ' - This function is typically used to identify the currency that should be marked as active in the system. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function CurrencyYouWantToBeActive() CurrencyYouWantToBeActive = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) End Function '********************************************************************** ' Sub: TestConvertCurrencyToWords ' Purpose: Tests the ConvertCurrencyToWords function by converting various numeric strings to words ' in both Arabic and English. ' Notes: The subroutine uses a set of test numbers, converts each to words in both languages, ' and displays the results using message boxes. ' It also confirms the completion of the test. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub TestConvertCurrencyToWords() Dim number As String Dim resultAr As String Dim resultEn As String ' Specify the numbers to be tested. Dim testNumbers As Variant testNumbers = Array("1234.56", "0", "-123.45", "1000000.99", "123456789.12") Dim i As Integer For i = LBound(testNumbers) To UBound(testNumbers) number = testNumbers(i) ' Convert the number to Arabic words resultAr = ConvertCurrencyToWords(number, "ar") MsgBox "Arabic Conversion for " & number & ": " & vbCrLf & resultAr, vbInformation, "Arabic Result" ' Convert the number to English words resultEn = ConvertCurrencyToWords(number, "en") MsgBox "English Conversion for " & number & ": " & vbCrLf & resultEn, vbInformation, "English Result" Next i ' Confirm trial end MsgBox "Conversion tests completed successfully.", vbInformation, "Test Completed" End Sub '********************************************************************** ' Sub: TestGetCurrencyValues ' Purpose: Tests the GetCurrencyValues function by retrieving currency values for both Arabic and English languages. ' Notes: The subroutine retrieves currency values for both languages and prints each value in the Immediate window. ' This helps verify that the function returns the correct values for different languages. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Sub TestGetCurrencyValues() Dim currencyValues As Variant Dim i As Integer ' Test for both languages Dim languages As Variant languages = Array("ar", "en") Dim lang As Variant For Each lang In languages ' Call the function and get the result currencyValues = GetCurrencyValues("") ' Print each value in the Immediate Window for debugging purposes Debug.Print "Currency Values for Language: " & lang For i = LBound(currencyValues) To UBound(currencyValues) Debug.Print currencyValues(i) Next i Debug.Print "---------------------------------------" Next lang End Sub '********************************************************************** ' Function: TableExists ' Purpose: Checks whether a table with the specified name exists in the current database. ' Inputs: tableName - A string representing the name of the table to check. ' The table name should be provided as a complete name (e.g., "Customers"). ' Returns: Boolean - Returns True if the table exists in the current database; ' otherwise, returns False. ' Notes: This function utilizes error handling to determine the existence of the table. ' If an error occurs (e.g., table does not exist), the function safely returns False. ' Ensure that the table name is correctly spelled and exists in the current database. ' The function relies on DAO (Data Access Objects) library to interact with the database. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function TableExists(TableName As String) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef ' Obtain a reference to the current database Set db = CurrentDb() ' Initialize error handling On Error Resume Next ' Attempt to set the TableDef object for the specified table Set tdf = db.TableDefs(TableName) ' Determine if the TableDef object was successfully set (table exists) TableExists = Not tdf Is Nothing ' Reset error handling On Error GoTo 0 ' Clean up objects to free memory Set tdf = Nothing Set db = Nothing End Function '********************************************************************** ' Sub: CreateCurrencyTable ' Purpose: Creates a new table named "tblCurrencyInfo" with predefined fields in the current database. ' Inputs: None ' Returns: None ' Notes: This subroutine initializes a new table definition object, defines the necessary fields ' for storing currency information, and appends the table definition to the database. ' The fields include both standard and language-specific currency information. ' After creating the table, it refreshes the database window to reflect the changes. ' Ensure that this table name does not conflict with existing tables in the database. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub CreateCurrencyTable() On Error GoTo ErrorHandler Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field ' Obtain a reference to the current database Set db = CurrentDb() ' Create a new TableDef object for "tblCurrencyInfo" Set tdf = db.CreateTableDef("tblCurrencyInfo") ' Define the fields for the new table With tdf ' Add fields with names and types .Fields.Append .CreateField("IsCurrencyActive", dbBoolean) .Fields.Append .CreateField("CurrencyNameSingular", dbText) .Fields.Append .CreateField("CurrencyNameDual", dbText) .Fields.Append .CreateField("CurrencyNamePlural", dbText) .Fields.Append .CreateField("CurrencyNameAccusative", dbText) .Fields.Append .CreateField("CurrencyBaseValue", dbInteger) .Fields.Append .CreateField("isCurrencyFeminine", dbBoolean) .Fields.Append .CreateField("NumberOfDecimalPlaces", dbInteger) .Fields.Append .CreateField("FractionalUnitSingular", dbText) .Fields.Append .CreateField("FractionalUnitDual", dbText) .Fields.Append .CreateField("FractionalUnitPlural", dbText) .Fields.Append .CreateField("FractionalUnitAccusative", dbText) .Fields.Append .CreateField("FractionalUnitBaseValue", dbInteger) .Fields.Append .CreateField("CurrencyNameSingularOtherLang", dbText) .Fields.Append .CreateField("CurrencyNameDualOtherLang", dbText) .Fields.Append .CreateField("CurrencyNamePluralOtherLang", dbText) .Fields.Append .CreateField("CurrencyNameAccusativeOtherLang", dbText) .Fields.Append .CreateField("CurrencyBaseValueOtherLang", dbInteger) .Fields.Append .CreateField("FractionalUnitSingularOtherLang", dbText) .Fields.Append .CreateField("FractionalUnitDualOtherLang", dbText) .Fields.Append .CreateField("FractionalUnitPluralOtherLang", dbText) .Fields.Append .CreateField("FractionalUnitAccusativeOtherLang", dbText) .Fields.Append .CreateField("FractionalUnitBaseValueOtherLang", dbInteger) .Fields.Append .CreateField("CurrencyISOCode", dbText) End With ' Append the new table definition to the database db.TableDefs.Append tdf ' Open the table definition to update captions and descriptions Set tdf = db.TableDefs("tblCurrencyInfo") ' Define captions and descriptions for each field Set fld = tdf.Fields("IsCurrencyActive") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(202) & Chr(221) & Chr(218) & Chr(237) & Chr(225) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(202) & Chr(221) & Chr(218) & Chr(237) & Chr(225) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(225) & Chr(199) & Chr(211) & Chr(202) & Chr(206) & Chr(207) & Chr(199) & Chr(227) & Chr(229) & Chr(199) & Chr(32) & Chr(221) & Chr(237) & Chr(32) & Chr(199) & Chr(225) & Chr(202) & Chr(216) & Chr(200) & Chr(237) & Chr(222) & Chr(199) & Chr(202)) Set fld = tdf.Fields("CurrencyNameSingular") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(221) & Chr(209) & Chr(207)) Set fld = tdf.Fields("CurrencyNameDual") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(203) & Chr(228) & Chr(236)) Set fld = tdf.Fields("CurrencyNamePlural") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(204) & Chr(227) & Chr(218) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(204) & Chr(227) & Chr(218)) Set fld = tdf.Fields("CurrencyNameAccusative") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200)) Set fld = tdf.Fields("CurrencyBaseValue") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(225) & Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201) & Chr(32) & Chr(225) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) Set fld = tdf.Fields("isCurrencyFeminine") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(229) & Chr(225) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(227) & Chr(196) & Chr(228) & Chr(203) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(202) & Chr(221) & Chr(218) & Chr(237) & Chr(225) & Chr(32) & Chr(228) & Chr(230) & Chr(218) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(32) & Chr(227) & Chr(196) & Chr(228) & Chr(203) & Chr(201) & Chr(32) & Chr(41) & Chr(32) & Chr(225) & Chr(199) & Chr(211) & Chr(202) & Chr(206) & Chr(207) & Chr(199) & Chr(227) & Chr(229) & Chr(199) & Chr(32) & Chr(221) & Chr(237) & Chr(32) & Chr(199) & Chr(225) & Chr(202) & Chr(216) & Chr(200) & Chr(237) & Chr(222) & Chr(199) & Chr(202)) Set fld = tdf.Fields("NumberOfDecimalPlaces") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(218) & Chr(207) & Chr(207) & Chr(32) & Chr(199) & Chr(225) & Chr(206) & Chr(199) & Chr(228) & Chr(199) & Chr(202) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(212) & Chr(209) & Chr(237) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(218) & Chr(207) & Chr(207) & Chr(32) & Chr(199) & Chr(225) & Chr(206) & Chr(199) & Chr(228) & Chr(199) & Chr(202) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(212) & Chr(209) & Chr(237) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(211) & Chr(202) & Chr(206) & Chr(207) & Chr(227) & Chr(201) & Chr(32) & Chr(221) & Chr(237) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) Set fld = tdf.Fields("FractionalUnitSingular") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(221) & Chr(209) & Chr(207)) Set fld = tdf.Fields("FractionalUnitDual") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(203) & Chr(228) & Chr(236)) Set fld = tdf.Fields("FractionalUnitPlural") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(204) & Chr(227) & Chr(218) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(204) & Chr(227) & Chr(218)) Set fld = tdf.Fields("FractionalUnitAccusative") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(41)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200)) Set fld = tdf.Fields("FractionalUnitBaseValue") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(225) & Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201) & Chr(32) & Chr(225) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) Set fld = tdf.Fields("CurrencyNameSingularOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("CurrencyNameDualOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("CurrencyNamePluralOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(204) & Chr(227) & Chr(218) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(204) & Chr(227) & Chr(218) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("CurrencyNameAccusativeOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("CurrencyBaseValueOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(225) & Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201) & Chr(32) & Chr(225) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("FractionalUnitSingularOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(221) & Chr(209) & Chr(207) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("FractionalUnitDualOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(203) & Chr(228) & Chr(236) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("FractionalUnitPluralOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(204) & Chr(227) & Chr(218) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(204) & Chr(227) & Chr(218) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("FractionalUnitAccusativeOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(40) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(41) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(211) & Chr(227) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(213) & Chr(237) & Chr(219) & Chr(201) & Chr(32) & Chr(205) & Chr(199) & Chr(225) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(228) & Chr(213) & Chr(200) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("FractionalUnitBaseValueOtherLang") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(199) & Chr(225) & Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(199) & Chr(225) & Chr(195) & Chr(211) & Chr(199) & Chr(211) & Chr(237) & Chr(201) & Chr(32) & Chr(225) & Chr(223) & Chr(211) & Chr(209) & Chr(32) & Chr(199) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201) & Chr(32) & Chr(200) & Chr(225) & Chr(219) & Chr(201) & Chr(32) & Chr(195) & Chr(206) & Chr(209) & Chr(236)) Set fld = tdf.Fields("CurrencyISOCode") fld.Properties.Append fld.CreateProperty("Caption", dbText, Chr(209) & Chr(227) & Chr(210) & Chr(32) & Chr(73) & Chr(83) & Chr(79) & Chr(32) & Chr(225) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) fld.Properties.Append fld.CreateProperty("Description", dbText, Chr(209) & Chr(227) & Chr(210) & Chr(32) & Chr(73) & Chr(83) & Chr(79) & Chr(32) & Chr(199) & Chr(225) & Chr(227) & Chr(206) & Chr(213) & Chr(213) & Chr(32) & Chr(225) & Chr(225) & Chr(218) & Chr(227) & Chr(225) & Chr(201)) ' Release objects Set tdf = Nothing Set db = Nothing ' Refresh the database window to show the new table Application.RefreshDatabaseWindow ' Optional: Notify the user that the table was created successfully ' MsgBox "The table was created and the label and description were set successfully. ", vbInformation Exit Sub ErrorHandler: If Err.number = 3010 Then ' Release objects Set tdf = Nothing Set db = Nothing Exit Sub Else ' Release objects Set tdf = Nothing Set db = Nothing End If ' Release objects Set tdf = Nothing Set db = Nothing End Sub '********************************************************************** ' Sub: CreateAndUpdateCurrencyTable ' Purpose: Ensures that the "tblCurrencyInfo" table is created and populated with default values. ' Inputs: None ' Returns: None ' Notes: This subroutine calls two other subroutines, CreateCurrencyTable and UpdateCurrencyTable, ' to first create the "tblCurrencyInfo" table and then populate it with default values. ' It is designed to streamline the process of setting up the currency table with ' the necessary data. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub CreateAndUpdateCurrencyTable() ' Ensure that the "tblCurrencyInfo" table is created CreateCurrencyTable ' Populate the "tblCurrencyInfo" table with default values UpdateCurrencyTable End Sub '********************************************************************** ' Function: GetCurrencyValues ' Purpose: Retrieves the values associated with a specific currency type, ' including its representations in both singular, dual, and plural forms ' for the specified language. ' Inputs: ' - Optional CurrencyType: The type of currency to retrieve values for. ' If not provided, defaults to an empty string which may result ' in fetching a default or active currency. ' - Optional language: The language for which the currency values should be retrieved. ' Defaults to "ar" (Arabic). ' Returns: Variant - An array containing the currency values in the specified language ' and formats (singular, dual, plural, etc.). ' Notes: ' - The function can be extended to handle different languages and currency formats. ' - If no CurrencyType is specified, it might fetch the values of a default or currently active currency. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function GetCurrencyValues(Optional CurrencyType As String = "", Optional language As String = "ar") As Variant On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim query As String Dim currencyValues() As Variant ' Open a connection to the current database Set db = CurrentDb ' Determine the query based on CurrencyType If CurrencyType <> "" Then query = "SELECT * FROM tblCurrencyInfo WHERE CurrencyNameSingular = '" & CurrencyType & "'" Else query = "SELECT * FROM tblCurrencyInfo WHERE IsCurrencyActive = TRUE" End If ' Open the recordset with the query Set rs = db.OpenRecordset(query) ' Check if the recordset is empty If rs.EOF Then ' Provide default currency values if no records are found If language = "ar" Then ReDim currencyValues(12) ' Increased size to include CurrencyISOCode, NumberOfDecimalPlaces, and isCurrencyFeminine ' Set default values for Arabic language currencyValues(0) = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) currencyValues(1) = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(228) currencyValues(2) = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(202) currencyValues(3) = Chr(204) & Chr(228) & Chr(237) & Chr(229) currencyValues(4) = "0" currencyValues(5) = Chr(222) & Chr(209) & Chr(212) currencyValues(6) = Chr(222) & Chr(209) & Chr(212) & Chr(199) & Chr(228) currencyValues(7) = Chr(222) & Chr(209) & Chr(230) & Chr(212) currencyValues(8) = Chr(222) & Chr(209) & Chr(212) currencyValues(9) = "0" currencyValues(10) = "EGP" ' Default CurrencyISOCode currencyValues(11) = 2 ' Default NumberOfDecimalPlaces currencyValues(12) = False ' Default isCurrencyFeminine Else ReDim currencyValues(12) ' Increased size to include CurrencyISOCode, NumberOfDecimalPlaces, and isCurrencyFeminine ' Set default values for English language currencyValues(0) = "Egyptian Pound" currencyValues(1) = "Two Egyptian Pounds" currencyValues(2) = "Egyptian Pounds" currencyValues(3) = "One Egyptian Pound" currencyValues(4) = "0" currencyValues(5) = "Piastre" currencyValues(6) = "Two Piastres" currencyValues(7) = "Piastres" currencyValues(8) = "One Piastre" currencyValues(9) = "0" currencyValues(10) = "EGP" ' Default CurrencyISOCode currencyValues(11) = 2 ' Default NumberOfDecimalPlaces currencyValues(12) = False ' Default isCurrencyFeminine End If ' Clean up and exit rs.Close Set rs = Nothing Set db = Nothing GetCurrencyValues = currencyValues Exit Function End If ' Determine which fields to retrieve based on the language parameter If language = "EN" Then ' Retrieve values for English ReDim currencyValues(12) ' Increased size to include CurrencyISOCode, NumberOfDecimalPlaces, and isCurrencyFeminine currencyValues(0) = rs.Fields("CurrencyNameSingularOtherLang").Value currencyValues(1) = rs.Fields("CurrencyNameDualOtherLang").Value currencyValues(2) = rs.Fields("CurrencyNamePluralOtherLang").Value currencyValues(3) = rs.Fields("CurrencyNameAccusativeOtherLang").Value currencyValues(4) = rs.Fields("CurrencyBaseValueOtherLang").Value currencyValues(5) = rs.Fields("FractionalUnitSingularOtherLang").Value currencyValues(6) = rs.Fields("FractionalUnitDualOtherLang").Value currencyValues(7) = rs.Fields("FractionalUnitPluralOtherLang").Value currencyValues(8) = rs.Fields("FractionalUnitAccusativeOtherLang").Value currencyValues(9) = rs.Fields("FractionalUnitBaseValueOtherLang").Value currencyValues(10) = rs.Fields("CurrencyISOCode").Value currencyValues(11) = rs.Fields("NumberOfDecimalPlaces").Value currencyValues(12) = rs.Fields("isCurrencyFeminine").Value Else ' Retrieve values for Arabic ReDim currencyValues(12) ' Increased size to include CurrencyISOCode, NumberOfDecimalPlaces, and isCurrencyFeminine currencyValues(0) = rs.Fields("CurrencyNameSingular").Value currencyValues(1) = rs.Fields("CurrencyNameDual").Value currencyValues(2) = rs.Fields("CurrencyNamePlural").Value currencyValues(3) = rs.Fields("CurrencyNameAccusative").Value currencyValues(4) = rs.Fields("CurrencyValue").Value currencyValues(5) = rs.Fields("FractionalUnitSingular").Value currencyValues(6) = rs.Fields("FractionalUnitDual").Value currencyValues(7) = rs.Fields("FractionalUnitPlural").Value currencyValues(8) = rs.Fields("FractionalUnitAccusative").Value currencyValues(9) = rs.Fields("FractionalUnitBaseValue").Value currencyValues(10) = rs.Fields("CurrencyISOCode").Value currencyValues(11) = rs.Fields("NumberOfDecimalPlaces").Value currencyValues(12) = rs.Fields("isCurrencyFeminine").Value End If ' Close the recordset and database connection rs.Close Set rs = Nothing Set db = Nothing ' Return the array of currency values GetCurrencyValues = currencyValues Exit Function ErrorHandler: ' Handle errors: If the table is missing, call CreateAndUpdateCurrencyTable to create it If Err.number = 3078 Then Call CreateAndUpdateCurrencyTable Resume Else ' MsgBox "An error occurred: " & Err.Description, vbCritical Resume Next End If End Function '********************************************************************** ' Function: ConvertToWords ' Purpose: Converts a numeric value to its word representation, including currency terms if desired. ' Inputs: ' - num: The numeric value as a string to be converted to words. ' - currencyTerms: An array containing currency-related terms such as singular, dual, and plural forms. ' - Optional lang: The target language for the conversion. Defaults to "ar" (Arabic). ' - Optional ShowCurrency: A boolean indicating whether to include currency terms in the output. Defaults to True. ' Returns: String - The numeric value converted to words, optionally with currency terms. ' Notes: ' - Handles both integer and fractional parts of the number. ' - Supports multiple languages for the conversion process. ' - The `currencyTerms` parameter should be structured as an array with specific order (e.g., singular, dual, plural). ' - If `ShowCurrency` is False, only the numeric value in words will be returned without currency terms. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function ConvertToWords(Num As String, currencyTerms As Variant, Optional lang As String = "ar", Optional ShowCurrency As Boolean = True) As String ', Optional CurrencyType As String = "" If Len(Num) >= 72 Then ' Handle the case when the string is too long On Error Resume Next ' Start error handling End If On Error GoTo 0 ' Reset error handling Dim units As Variant Dim unitsAlternate As Variant Dim tens As Variant Dim largeUnits As Variant Dim largeUnitsAlternate As Variant Dim unitsEn As Variant Dim tensEn As Variant Dim largeUnitsEn As Variant Dim i As Integer Dim segment As String Dim hundreds As Integer Dim tensValue As Integer Dim unitsValue As Integer Dim words As String Dim segmentSuffix As Integer ' Arabic values Dim arabicZero As String: arabicZero = Chr(213) & Chr(221) & Chr(209) Dim arabicOneFeminine As String: arabicOneFeminine = Chr(230) & Chr(199) & Chr(205) & Chr(207) & Chr(201) Dim arabicOne As String: arabicOne = Chr(230) & Chr(199) & Chr(205) & Chr(207) Dim arabicTwo As String: arabicTwo = Chr(199) & Chr(203) & Chr(228) & Chr(199) & Chr(228) Dim arabicThree As String: arabicThree = Chr(203) & Chr(225) & Chr(199) & Chr(203) & Chr(201) Dim arabicFour As String: arabicFour = Chr(195) & Chr(209) & Chr(200) & Chr(218) & Chr(201) Dim arabicFive As String: arabicFive = Chr(206) & Chr(227) & Chr(211) & Chr(201) Dim arabicSix As String: arabicSix = Chr(211) & Chr(202) & Chr(201) Dim arabicSeven As String: arabicSeven = Chr(211) & Chr(200) & Chr(218) & Chr(201) Dim arabicEight As String: arabicEight = Chr(203) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(201) Dim arabicNine As String: arabicNine = Chr(202) & Chr(211) & Chr(218) & Chr(201) Dim arabicTen As String: arabicTen = Chr(218) & Chr(212) & Chr(209) & Chr(201) Dim arabicEleven As String: arabicEleven = Chr(195) & Chr(205) & Chr(207) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicTwelve As String: arabicTwelve = Chr(199) & Chr(203) & Chr(228) & Chr(199) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicThirteen As String: arabicThirteen = Chr(203) & Chr(225) & Chr(199) & Chr(203) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicFourteen As String: arabicFourteen = Chr(195) & Chr(209) & Chr(200) & Chr(218) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicFifteen As String: arabicFifteen = Chr(206) & Chr(227) & Chr(211) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicSixteen As String: arabicSixteen = Chr(211) & Chr(202) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicSeventeen As String: arabicSeventeen = Chr(211) & Chr(200) & Chr(218) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicEighteen As String: arabicEighteen = Chr(203) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicNineteen As String: arabicNineteen = Chr(202) & Chr(211) & Chr(218) & Chr(201) & Chr(32) & Chr(218) & Chr(212) & Chr(209) Dim arabicTwenty As String: arabicTwenty = Chr(218) & Chr(212) & Chr(209) & Chr(230) & Chr(228) Dim arabicThirty As String: arabicThirty = Chr(203) & Chr(225) & Chr(199) & Chr(203) & Chr(230) & Chr(228) Dim arabicForty As String: arabicForty = Chr(195) & Chr(209) & Chr(200) & Chr(218) & Chr(230) & Chr(228) Dim arabicFifty As String: arabicFifty = Chr(206) & Chr(227) & Chr(211) & Chr(230) & Chr(228) Dim arabicSixty As String: arabicSixty = Chr(211) & Chr(202) & Chr(230) & Chr(228) Dim arabicSeventy As String: arabicSeventy = Chr(211) & Chr(200) & Chr(218) & Chr(230) & Chr(228) Dim arabicEighty As String: arabicEighty = Chr(203) & Chr(227) & Chr(199) & Chr(228) & Chr(230) & Chr(228) Dim arabicNinety As String: arabicNinety = Chr(202) & Chr(211) & Chr(218) & Chr(230) & Chr(228) Dim arabicHundred As String: arabicHundred = Chr(227) & Chr(199) & Chr(198) & Chr(201) Dim arabicTwoHundred As String: arabicTwoHundred = Chr(227) & Chr(199) & Chr(198) & Chr(202) & Chr(199) & Chr(228) Dim arabicAlternateOne As String: arabicAlternateOne = Chr(197) & Chr(205) & Chr(207) & Chr(236) Dim arabicAlternateTwo As String: arabicAlternateTwo = Chr(199) & Chr(203) & Chr(228) & Chr(202) & Chr(199) & Chr(228) Dim arabicThousand As String: arabicThousand = Chr(195) & Chr(225) & Chr(221) Dim arabicThousandAlternate As String: arabicThousandAlternate = Chr(194) & Chr(225) & Chr(199) & Chr(221) Dim arabicMillion As String: arabicMillion = Chr(227) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicMillionAlternate As String: arabicMillionAlternate = Chr(227) & Chr(225) & Chr(199) & Chr(237) & Chr(237) & Chr(228) Dim arabicBillion As String: arabicBillion = Chr(200) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicBillionAlternate As String: arabicBillionAlternate = Chr(200) & Chr(225) & Chr(199) & Chr(237) & Chr(237) & Chr(228) Dim arabicTrillion As String: arabicTrillion = Chr(202) & Chr(209) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicTrillionAlternate As String: arabicTrillionAlternate = Chr(202) & Chr(209) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicQuadrillion As String: arabicQuadrillion = Chr(223) & Chr(230) & Chr(199) & Chr(207) & Chr(209) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicQuadrillionAlternate As String: arabicQuadrillionAlternate = Chr(223) & Chr(230) & Chr(199) & Chr(207) & Chr(209) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicQuintillion As String: arabicQuintillion = Chr(223) & Chr(230) & Chr(237) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicQuintillionAlternate As String: arabicQuintillionAlternate = Chr(223) & Chr(230) & Chr(237) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicSextillion As String: arabicSextillion = Chr(211) & Chr(223) & Chr(211) & Chr(202) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicSextillionAlternate As String: arabicSextillionAlternate = Chr(211) & Chr(223) & Chr(211) & Chr(202) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicSeptillion As String: arabicSeptillion = Chr(211) & Chr(237) & Chr(200) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicSeptillionAlternate As String: arabicSeptillionAlternate = Chr(211) & Chr(237) & Chr(200) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicOctillion As String: arabicOctillion = Chr(195) & Chr(230) & Chr(223) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicOctillionAlternate As String: arabicOctillionAlternate = Chr(195) & Chr(230) & Chr(223) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicNonillion As String: arabicNonillion = Chr(228) & Chr(230) & Chr(228) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicNonillionAlternate As String: arabicNonillionAlternate = Chr(228) & Chr(230) & Chr(228) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicDecillion As String: arabicDecillion = Chr(207) & Chr(237) & Chr(212) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicDecillionAlternate As String: arabicDecillionAlternate = Chr(207) & Chr(237) & Chr(212) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicUndecillion As String: arabicUndecillion = Chr(195) & Chr(230) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicUndecillionAlternate As String: arabicUndecillionAlternate = Chr(195) & Chr(230) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicDuodecillion As String: arabicDuodecillion = Chr(207) & Chr(230) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicDuodecillionAlternate As String: arabicDuodecillionAlternate = Chr(207) & Chr(230) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicTredecillion As String: arabicTredecillion = Chr(202) & Chr(209) & Chr(237) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicTredecillionAlternate As String: arabicTredecillionAlternate = Chr(202) & Chr(209) & Chr(237) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicQuattuordecillion As String: arabicQuattuordecillion = Chr(223) & Chr(230) & Chr(199) & Chr(202) & Chr(230) & Chr(209) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicQuattuordecillionAlternate As String: arabicQuattuordecillionAlternate = Chr(223) & Chr(230) & Chr(199) & Chr(202) & Chr(230) & Chr(209) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicQuindecillion As String: arabicQuindecillion = Chr(223) & Chr(230) & Chr(237) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicQuindecillionAlternate As String: arabicQuindecillionAlternate = Chr(223) & Chr(230) & Chr(237) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicSexdecillion As String: arabicSexdecillion = Chr(211) & Chr(223) & Chr(211) & Chr(202) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicSexdecillionAlternate As String: arabicSexdecillionAlternate = Chr(211) & Chr(223) & Chr(211) & Chr(202) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicSeptendecillion As String: arabicSeptendecillion = Chr(211) & Chr(237) & Chr(200) & Chr(202) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicSeptendecillionAlternate As String: arabicSeptendecillionAlternate = Chr(211) & Chr(237) & Chr(200) & Chr(202) & Chr(228) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicOctodecillion As String: arabicOctodecillion = Chr(195) & Chr(230) & Chr(223) & Chr(202) & Chr(230) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicOctodecillionAlternate As String: arabicOctodecillionAlternate = Chr(195) & Chr(230) & Chr(223) & Chr(202) & Chr(230) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicNovemdecillion As String: arabicNovemdecillion = Chr(228) & Chr(230) & Chr(221) & Chr(237) & Chr(227) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicNovemdecillionAlternate As String: arabicNovemdecillionAlternate = Chr(228) & Chr(230) & Chr(221) & Chr(237) & Chr(227) & Chr(207) & Chr(237) & Chr(211) & Chr(237) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicVigintillion As String: arabicVigintillion = Chr(221) & Chr(237) & Chr(204) & Chr(237) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicVigintillionAlternate As String: arabicVigintillionAlternate = Chr(221) & Chr(237) & Chr(204) & Chr(237) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicCentillion As String: arabicCentillion = Chr(211) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) Dim arabicCentillionAlternate As String: arabicCentillionAlternate = Chr(211) & Chr(228) & Chr(202) & Chr(225) & Chr(237) & Chr(230) & Chr(228) & Chr(199) & Chr(202) Dim arabicGoogol As String: arabicGoogol = Chr(204) & Chr(230) & Chr(204) & Chr(230) & Chr(225) units = Array(arabicZero, arabicOne, arabicTwo, arabicThree, arabicFour, arabicFive, arabicSix, arabicSeven, arabicEight, arabicNine, arabicTen, arabicEleven, arabicTwelve, _ arabicThirteen, arabicFourteen, arabicFifteen, arabicSixteen, arabicSeventeen, arabicEighteen, arabicNineteen) unitsAlternate = Array(arabicZero, arabicAlternateOne, arabicAlternateTwo, Chr(203) & Chr(225) & Chr(199) & Chr(203), Chr(195) & Chr(209) & Chr(200) & Chr(218), _ Chr(206) & Chr(227) & Chr(211), Chr(211) & Chr(202), Chr(211) & Chr(200) & Chr(218), Chr(203) & Chr(227) & Chr(199) & Chr(228), Chr(202) & Chr(211) & Chr(218), _ Chr(218) & Chr(212) & Chr(209), Chr(197) & Chr(205) & Chr(207) & Chr(236) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), Chr(199) & Chr(203) & Chr(228) & Chr(202) & Chr(199) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), _ Chr(203) & Chr(225) & Chr(199) & Chr(203) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), Chr(195) & Chr(209) & Chr(200) & Chr(218) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), _ Chr(206) & Chr(227) & Chr(211) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), Chr(211) & Chr(202) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), _ Chr(211) & Chr(200) & Chr(218) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), Chr(203) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201), _ Chr(202) & Chr(211) & Chr(218) & Chr(32) & Chr(218) & Chr(212) & Chr(209) & Chr(201)) tens = Array("", "", arabicTwenty, arabicThirty, arabicForty, arabicFifty, arabicSixty, arabicSeventy, arabicEighty, arabicNinety) largeUnits = Array("", arabicThousand, arabicMillion, arabicBillion, arabicTrillion, arabicQuadrillion, arabicQuintillion, arabicSextillion, arabicSeptillion, arabicOctillion, arabicNonillion, arabicDecillion, arabicUndecillion, arabicDuodecillion, arabicTredecillion, arabicQuattuordecillion, arabicQuindecillion, arabicSexdecillion, arabicSeptendecillion, arabicOctodecillion, arabicNovemdecillion, arabicVigintillion, arabicCentillion, arabicGoogol) largeUnitsAlternate = Array("", arabicThousandAlternate, arabicMillionAlternate, arabicBillionAlternate, arabicTrillionAlternate, arabicQuadrillionAlternate, arabicQuintillionAlternate, arabicSextillionAlternate, arabicSeptillionAlternate, arabicOctillionAlternate, arabicNonillionAlternate, arabicDecillionAlternate, arabicUndecillionAlternate, arabicDuodecillionAlternate, arabicTredecillionAlternate, arabicQuattuordecillionAlternate, arabicQuindecillionAlternate, arabicSexdecillionAlternate, arabicSeptendecillionAlternate, arabicOctodecillionAlternate, arabicNovemdecillionAlternate, arabicVigintillionAlternate, arabicCentillionAlternate, arabicGoogol) ' English values unitsEn = Array("zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen") tensEn = Array("", "", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety") ' English values unitsEn = Array("zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen") tensEn = Array("", "", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety") largeUnitsEn = Array("", "thousand", "million", "billion", "trillion", "quadrillion", "quintillion", "sextillion", "septillion", "octillion", "nonillion", "decillion", "undecillion", "duodecillion", "tredecillion", "quattuordecillion", "quindecillion", "sexdecillion", "septendecillion", "octodecillion", "novemdecillion", "vigintillion", "centillion", "googol") ' Initialize words to empty words = "" ' Process each segment of the number (three digits at a time) ' If the number is too large, convert it to scientific notation If Len(Num) >= 21 Then Num = Format(Num, "0E+0") Else Num = Format(Num, "0") End If ' Split the number into segments of three digits For i = 0 To Int((Len(Num) - 1) / 3) segment = Right(Mid(Num, 1, Len(Num) - i * 3), 3) ' Convert the segment to an integer If IsNumeric(segment) Then segment = CInt(segment) ' Process hundreds and tens hundreds = Int(segment / 100) tensValue = segment Mod 100 ' Perform the necessary operations with hundreds and tensValue ' (Add your specific logic here) Else ' Handle cases where segment is not numeric (in case of scientific notation) ' You might want to skip or handle these differently End If segmentSuffix = IIf(i = 0, currencyTerms(4), 0) ' Process tens and units If tensValue > 0 Then If tensValue < 20 Then ' Handle numbers from 1 to 19 If lang = "ar" Then On Error Resume Next words = IIf(tensValue > 2, IIf(segmentSuffix = 0, units(tensValue), unitsAlternate(tensValue)) & " " & IIf(tensValue > 10 And Len(largeUnits(i)) > 0, largeUnits(i) & IIf(words <> "", Chr(32) & Chr(230) & Chr(32), ""), largeUnitsAlternate(i)), IIf(Len(largeUnits(i)) > 0, largeUnits(i) & IIf(tensValue = 1, "", IIf(tensValue = 2 And words <> "" Or ShowCurrency = False, Chr(199) & Chr(228), Chr(199))), IIf(tensValue Mod 10 <> 0, "", IIf(segmentSuffix = 0, units(tensValue), unitsAlternate(tensValue))))) & IIf(words = "", IIf(Len(largeUnits(i)) > 0, " " & IIf(ShowCurrency, currencyTerms(0), ""), IIf(tensValue = 1, IIf(ShowCurrency, currencyTerms(0), arabicOne), IIf(tensValue = 2, IIf(ShowCurrency, currencyTerms(1), arabicTwo), IIf(tensValue < 11, IIf(ShowCurrency, currencyTerms(2), ""), IIf(ShowCurrency, currencyTerms(3), ""))))), Chr(32) & Chr(230) & Chr(32) & words) Else On Error Resume Next words = unitsEn(tensValue) & " " & largeUnitsEn(i) & IIf(words = "", IIf(Len(largeUnits(i)) > 0, " ", "") & IIf(Num > 1, IIf(ShowCurrency, currencyTerms(2), ""), IIf(ShowCurrency, currencyTerms(0), "")), " " & words) End If On Error GoTo 0 ' Reset the error handling Else ' Handle numbers from 20 and above If lang = "ar" Then words = IIf(tensValue Mod 10 = 0, "", IIf(segmentSuffix = 0, units(tensValue Mod 10), IIf(tensValue Mod 10 = 8, Left(unitsAlternate(8), 4), unitsAlternate(tensValue Mod 10))) & Chr(32) & Chr(230) & Chr(32)) & tens(Int(tensValue / 10)) & " " & largeUnits(i) & IIf(words <> "" And Len(largeUnits(i)) > 0, Chr(32) & Chr(230) & Chr(32), "") & IIf(words = "", IIf(Len(largeUnits(i)) > 0, " " & IIf(ShowCurrency, currencyTerms(0), ""), IIf(ShowCurrency, currencyTerms(3), "")), Chr(32) & Chr(230) & Chr(32) & words) Else words = tensEn(Int(tensValue / 10)) & IIf(tensValue Mod 10 = 0, "", "-") & unitsEn(tensValue Mod 10) & " " & largeUnitsEn(i) & IIf(words = "", IIf(Len(largeUnits(i)) > 0, " ", "") & IIf(Num > 1, IIf(ShowCurrency, currencyTerms(2), ""), IIf(ShowCurrency, currencyTerms(0), "")), " " & words) End If End If End If ' Process hundreds If hundreds > 0 Then If lang = "ar" Then On Error Resume Next words = IIf(hundreds = 1, Chr(227) & Chr(199) & Chr(198) & Chr(201), IIf(hundreds = 2, Chr(227) & Chr(199) & Chr(198) & Chr(202) & Chr(199) & IIf(tensValue > 0 Or ShowCurrency = False, Chr(228), ""), Mid(units(hundreds), 1, Len(units(hundreds)) - IIf(hundreds = 8, 2, 1)) & Chr(227) & Chr(199) & Chr(198) & Chr(201))) & IIf(tensValue = 0, IIf(Len(largeUnits(i)) > 0, " ", "") & largeUnits(i), "") & IIf(words = "", " " & IIf(ShowCurrency, currencyTerms(0), ""), Chr(32) & Chr(230) & Chr(32) & words) Else On Error Resume Next words = unitsEn(hundreds) & " hundred" & IIf(tensValue > 0, "", " " & largeUnitsEn(i)) & IIf(words = "", IIf(Len(largeUnits(i)) > 0, " ", "") & IIf(Num > 1, IIf(ShowCurrency, currencyTerms(2), ""), IIf(ShowCurrency, currencyTerms(0), "")), " " & words) On Error GoTo 0 ' Reset the error handling End If End If Next i ' Process Zeros If (segment = "" Or segment = "0") And tensValue = 0 And ShowCurrency = False Then If lang = "ar" Then words = arabicZero Else words = unitsEn(0) End If End If ' Check if the number is 1 (for singular currency terms) If val(Num) = 1 Then If lang = "ar" Then If segmentSuffix Then words = IIf(ShowCurrency, currencyTerms(0), "") & " " & arabicOneFeminine Else words = IIf(ShowCurrency, currencyTerms(0), "") & " " & arabicOne End If Else words = unitsEn(1) & " " & IIf(ShowCurrency, currencyTerms(0), "") End If End If ' Return the result ConvertToWords = words End Function '********************************************************************** ' Function: ConvertCurrencyToWords ' Purpose: Converts a numeric value to its word representation in a specified language, ' with optional currency terms and additional formatting options. ' Inputs: ' - Number: The numeric value to be converted. Can be an integer or a floating-point number. ' - Optional CurrencyType: Specifies the currency type for which the number should be converted ' into words (e.g., Dollars, Euros). If not provided, it defaults to an empty string. ' - Optional language: The target language for the word representation. ' Defaults to "ar" (Arabic), but can be set to other languages such as "en" (English). ' - Optional ShowExtras: A boolean flag that determines whether additional information like ' currency units (e.g., cents, piastres) or other formatting should be included. ' Defaults to True. ' Returns: String - The numeric value expressed in words, formatted according to the specified language ' and currency type. ' Notes: ' - Handles both integer and fractional parts of the number. ' - The function can be extended to support additional languages and currencies. ' - The ShowExtras parameter allows for customized output, enabling or disabling extra formatting based on user preference. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function ConvertCurrencyToWords(number As Variant, Optional CurrencyType As String = "", Optional language As String = "ar", Optional ShowExtras As Boolean = True) As String ' Check if the input is not a numeric value If Not IsNumeric(number) Then ' If the language is Arabic, return an "Invalid value" message in Arabic If language = "ar" Then ConvertCurrencyToWords = "" ' If the language is English, return an "Invalid value" message in English ElseIf language = "En" Then ConvertCurrencyToWords = "" ' Otherwise, return the original number (using Nz to handle Null values) End If ' Exit the function if the value is not numeric Exit Function ' Check if the number is empty or has zero length ElseIf Nz(number, "") = "" Or Len(Nz(number, "")) = "" Then ConvertCurrencyToWords = "" ' Return an empty string Exit Function ' Check if the number is zero ElseIf CDbl(number) = 0 Then ' If the language is Arabic, return "Zero" in Arabic If language = "ar" Then ConvertCurrencyToWords = Chr(213) & Chr(221) & Chr(209) ' If the language is English, return "Zero" ElseIf language = "En" Then ConvertCurrencyToWords = "Zero" ' Otherwise, return the number itself ElseIf Len(number) >= 72 Then Resume Next Else ConvertCurrencyToWords = number End If ' Exit the function if the value is zero Exit Function End If ' Determine if the number is negative Dim isNegative As Boolean isNegative = (number < 0) ' If the number is negative, convert it to a positive value If isNegative Then number = Abs(number) End If ' If the number has 21 or more digits, convert it to scientific notation If Len(number) >= 21 Then number = Format(number, "0E+0") ' Define CurrencyUnits and CurrencySubUnits based on CurrencyType Dim CurrencyUnits As Variant Dim CurrencySubUnits As Variant Dim PrefixText As String Dim SuffixText As String Dim currencyValues As Variant Dim NumberOfDecimalPlaces As Integer Dim isCurrencyFeminine As Boolean ' Get currency values based on the language and CurrencyType currencyValues = GetCurrencyValues(CurrencyType, language) NumberOfDecimalPlaces = IIf(ShowExtras, IIf(IsNumeric(currencyValues(11)), currencyValues(11), 2), 3) isCurrencyFeminine = IIf(ShowExtras, currencyValues(12), False) If language = "ar" Then CurrencyUnits = Array(currencyValues(0), currencyValues(1), currencyValues(2), currencyValues(3), currencyValues(4)) CurrencySubUnits = Array(currencyValues(5), currencyValues(6), currencyValues(7), currencyValues(8), isCurrencyFeminine) PrefixText = IIf(ShowExtras, Chr(32) & Chr(221) & Chr(222) & Chr(216) & Chr(32), "") SuffixText = IIf(ShowExtras, Chr(225) & Chr(199) & Chr(32) & Chr(219) & Chr(237) & Chr(209), "") Else CurrencyUnits = Array(currencyValues(0), currencyValues(1), currencyValues(2), currencyValues(3), currencyValues(4)) CurrencySubUnits = Array(currencyValues(5), currencyValues(6), currencyValues(7), currencyValues(8), currencyValues(9), isCurrencyFeminine) PrefixText = IIf(ShowExtras, "Just", "") SuffixText = IIf(ShowExtras, "nothing more", "") End If Dim fullNumber As Variant Dim integerPart As String Dim fractionalPart As String Dim integerWords As String Dim fractionalWords As String If IsNumeric(number) And number > 0 Then fullNumber = Split(IIf(InStr(number, ".") > 0, number, number & ".0"), ".") integerPart = IIf(Len(fullNumber(0)) > 21, Right(fullNumber(0), 21), fullNumber(0)) fractionalPart = Mid(fullNumber(1) & String(20, "0"), 1, NumberOfDecimalPlaces) integerWords = ConvertToWords(integerPart, CurrencyUnits, language, ShowExtras) If ShowExtras = True Then On Error Resume Next fractionalWords = IIf(fractionalPart > 0, ConvertToWords(fractionalPart, CurrencySubUnits, language, ShowExtras), "") On Error GoTo 0 ' Reset the error handling Else fractionalPart = fullNumber(1) fractionalWords = IIf(fractionalPart > 0, ConvertToWords(fractionalPart, CurrencySubUnits, language, ShowExtras), "") End If fractionalWords = IIf(Len(fractionalWords) > 0, IIf(ShowExtras, "", IIf(language = "Ar", Chr(32) & Chr(221) & Chr(199) & Chr(213) & Chr(225) & Chr(32), " point ")) & fractionalWords, fractionalWords) Dim ResultConvert As String ResultConvert = PrefixText & " " & IIf(isNegative, IIf(language = "Ar", Chr(211) & Chr(199) & Chr(225) & Chr(200), "Negative") & " ", "") & integerWords & IIf(Len(integerWords) > 0 And Len(fractionalWords) > 0, IIf(language = "ar", IIf(ShowExtras, Chr(32) & Chr(230) & Chr(32), ""), IIf(ShowExtras, " and ", "")), "") & fractionalWords & " " & SuffixText ResultConvert = Trim(Replace(ResultConvert, " ", " ")) If ResultConvert = Chr(221) & Chr(222) & Chr(216) & " " & Chr(225) & Chr(199) & Chr(32) & Chr(219) & Chr(237) & Chr(209) Then ResultConvert = "" If ResultConvert = "Only" & Space(1) & "No more" Then ResultConvert = "" ConvertCurrencyToWords = ResultConvert Else ConvertCurrencyToWords = Chr(222) & Chr(237) & Chr(227) & Chr(201) & Chr(32) & Chr(219) & Chr(237) & Chr(209) & Chr(32) & Chr(213) & Chr(199) & Chr(225) & Chr(205) & Chr(201) End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Start code Convert NumberTo Words with out Currency Data "" Just Only Number ' ' ' ' ' ' '********************************************************************** ' Function: GenerateLeadingZerosText ' Purpose: Generates a textual representation of leading zeros in a number. ' Inputs: s - A string representing the numeric value to analyze. ' lang - An optional string specifying the language ("ar" for Arabic, "en" for English). ' Returns: String - A textual representation of the leading zeros. ' Notes: This function returns a string of "zero and" or "صفر و" for each leading zero ' depending on the specified language. If an unsupported language is provided, ' it returns "Unsupported language". '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function GenerateLeadingZerosText(s As String, Optional lang As String = "ar") As String Dim zeroCount As Integer Dim resultText As String Dim zeroWord As String ' Determine the word for zero based on the specified language If lang = "ar" Then zeroWord = Chr(213) & Chr(221) & Chr(209) & Chr(32) & Chr(230) ElseIf lang = "en" Then zeroWord = "zero and " Else GenerateLeadingZerosText = "Unsupported language" Exit Function End If zeroCount = 0 ' Count leading zeros and build the result string Do While Mid(s, zeroCount + 1, 1) = "0" And zeroCount < Len(s) resultText = resultText & zeroWord & " " zeroCount = zeroCount + 1 Loop ' Remove the trailing space if there were leading zeros If Len(resultText) > 0 Then resultText = Left(resultText, Len(resultText) - 1) End If GenerateLeadingZerosText = resultText End Function '********************************************************************** ' Function: ExtractNumberParts ' Purpose: Extracts the integer and decimal parts of a number string. ' Inputs: number - A string representing the numeric value to be extracted. ' integerPart - A ByRef string to hold the integer part of the number. ' decimalPart - A ByRef string to hold the decimal part of the number. ' DecimalRound - An optional integer specifying the number of decimal places to round. ' Returns: String - A formatted string indicating the extracted parts. ' Notes: This function handles the extraction of integer and decimal parts ' from a numeric string and provides a formatted result. If there are ' decimals, they are processed accordingly. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function ExtractNumberParts(number As String, ByRef integerPart As String, ByRef decimalPart As String, Optional DecimalRound As Integer = 10) As String Dim numString As String Dim decimalPosition As Integer Dim decimalLength As Integer numString = CStr(number) decimalPosition = InStr(numString, ".") If decimalPosition > 0 Then integerPart = Left(numString, decimalPosition - 1) decimalPart = Mid(numString, decimalPosition + 1) decimalLength = Len(decimalPart) Else integerPart = numString decimalPart = "" End If Dim result As String result = "Integer Part: " & integerPart & ", Decimal Part: " & decimalPart ' Debug.Print "Integer Part :" & integerPart ' Debug.Print "Decimal Part :" & decimalPart ExtractNumberParts = result End Function '********************************************************************** ' Function: ConvertNumberToWords ' Purpose: Converts a numeric string into its textual representation, including ' both integer and decimal parts, in the specified language. ' Inputs: num - A string representing the numeric value to be converted. ' lang - An optional string specifying the language ("ar" for Arabic, "en" for English). ' Returns: String - The textual representation of the numeric value, including ' integer, leading zeros, and decimal parts. ' Notes: This function combines the integer and decimal parts into a final ' textual representation, using appropriate conjunctions based on ' the specified language. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function ConvertNumberToWords(Num As String, Optional lang As String = "ar") As String Dim integerPart As String Dim decimalPart As String Dim integerWords As String Dim decimalWords As String Dim leadingZerosWords As String Dim conjunction As String Dim strNegative As String Dim isNegative As Boolean ' Extract integer and decimal parts of the number Call ExtractNumberParts(Num, integerPart, decimalPart) ' Convert integer and decimal parts to words integerWords = ConvertCurrencyToWords(integerPart, "", lang, False) decimalWords = ConvertCurrencyToWords(decimalPart, "", lang, False) If InStr(integerPart, "-") > 0 Then isNegative = True strNegative = IIf(lang = "ar", Chr(32) & Chr(211) & Chr(199) & Chr(225) & Chr(200), " Negative ") Else isNegative = False strNegative = IIf(lang = "ar", "", "") End If ' Generate leading zeros text if applicable leadingZerosWords = GenerateLeadingZerosText(decimalPart, lang) ' Define the prefix and suffix based on the language Dim prefix As String: prefix = IIf(lang = "ar", Chr(221) & Chr(222) & Chr(216), "Just ") Dim suffix As String: suffix = IIf(lang = "ar", Chr(32) & Chr(225) & Chr(199) & Chr(32) & Chr(219) & Chr(237) & Chr(209), " nothing more") Dim result As String ' Determine the conjunction based on the specified language If decimalWords = "" Then result = " " & prefix & " " & strNegative & " " & integerWords & " " & suffix & " " Else If lang = "ar" Then conjunction = Chr(32) & Chr(221) & Chr(199) & Chr(213) & Chr(225) & Chr(32) ElseIf lang = "en" Then conjunction = " Point " End If result = " " & prefix & " " & strNegative & " " & integerWords & " " & conjunction & " " & leadingZerosWords & " " & decimalWords & " " & suffix & " " End If ' Return an empty string if both integerWords and decimalWords are empty If integerWords = "" And decimalWords = "" Then result = "": Exit Function result = Replace(result, "and Zero nothing more", " nothing more") result = Replace(result, "Just Invalid value nothing more", "") result = Replace(result, "Point Invalid value", "") result = Replace(result, Chr(32) & Chr(230) & Chr(213) & Chr(221) & Chr(209) & Chr(32) & Chr(225) & Chr(199) & Chr(32) & Chr(219) & Chr(237) & Chr(209), _ Chr(32) & Chr(225) & Chr(199) & Chr(32) & Chr(219) & Chr(237) & Chr(209)) result = Replace(result, Chr(32) & Chr(230) & Chr(32) & Chr(230) & Chr(32), Chr(32) & Chr(230) & Chr(32)) result = Replace(result, " ", " ") ConvertNumberToWords = result End Function ' End >>---> code Convert NumberTo Words with out Currency Data "" Just Only Number ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '********************************************************************** ' Subroutine: LoadCurrencyNames ' Purpose: Loads currency names from the tblCurrencyInfo table into a collection. ' Inputs: None. ' Outputs: None. ' Returns: None. ' Notes: - The subroutine connects to the current database and retrieves ' the singular currency names from the tblCurrencyInfo table. ' - Currency names are stored in a Collection object to ensure ' unique entries (duplicates are ignored). ' - The subroutine demonstrates how to iterate over the collection ' and print the currency names to the debug console. ' - Error handling is used to manage duplicate entries gracefully. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub LoadCurrencyNames() Dim db As DAO.Database Dim rs As DAO.Recordset Dim currencyNames As Collection Dim currencyName As String Dim i As Integer ' Initialize the database object Set db = CurrentDb Set currencyNames = New Collection ' Open the recordset for the table tblCurrencyInfo Set rs = db.OpenRecordset("SELECT CurrencyNameSingular FROM tblCurrencyInfo", dbOpenSnapshot) ' Check if the recordset is not empty If Not rs.EOF Then ' Loop through each record and add the currency names to the collection Do While Not rs.EOF currencyName = rs!CurrencyNameSingular On Error Resume Next ' To handle duplicate entries currencyNames.Add currencyName, CStr(currencyName) On Error GoTo 0 ' Reset error handling rs.MoveNext Loop End If ' Close the recordset rs.Close Set rs = Nothing Set db = Nothing ' Example of how to use the collection For i = 1 To currencyNames.Count Debug.Print currencyNames(i) Next i End Sub '********************************************************************** ' Subroutine: PopulateComboBox ' Purpose: Populates a ComboBox with a list of currency names from the database. ' Inputs: cmbBox - The ComboBox control to be populated. ' Outputs: None. ' Returns: None. ' Notes: - This subroutine retrieves currency names from the "tblCurrencyInfo" ' table and adds them to the provided ComboBox. ' - It uses a Collection to temporarily store the currency names, ' ensuring no duplicates are added. ' - The ComboBox is cleared of existing items before new items are added. ' - Handles potential errors when adding duplicate entries to the Collection. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub PopulateComboBox(cmbBox As ComboBox) Dim db As DAO.Database Dim rs As DAO.Recordset Dim currencyNames As Collection Dim currencyName As String Dim i As Integer ' Initialize the database object Set db = CurrentDb Set currencyNames = New Collection ' Open the recordset for the table tblCurrencyInfo Set rs = db.OpenRecordset("SELECT CurrencyNameSingular FROM tblCurrencyInfo", dbOpenSnapshot) ' Check if the recordset is not empty If Not rs.EOF Then ' Loop through each record and add the currency names to the collection Do While Not rs.EOF currencyName = rs!CurrencyNameSingular On Error Resume Next ' To handle duplicate entries currencyNames.Add currencyName, CStr(currencyName) On Error GoTo 0 ' Reset error handling rs.MoveNext Loop End If ' Close the recordset rs.Close Set rs = Nothing Set db = Nothing ' Clear existing items in the ComboBox cmbBox.RowSource = "" ' Add items to the ComboBox from the collection For i = 1 To currencyNames.Count cmbBox.AddItem currencyNames(i) Next i End Sub '********************************************************************** ' Subroutine: CleanUpVariables ' Purpose: Resets all currency-related variables to their default values. ' Inputs: None. ' Outputs: None. ' Returns: None. ' Notes: - This subroutine is used to clean up or reset variables that store ' currency information in both Arabic and other languages. ' - It sets string variables to `vbNullString` (an empty string) ' and numerical variables to their default values. ' - It is useful to call this subroutine before loading new currency ' data or when you need to ensure that old data is cleared out. ' - The `NumberOfDecimalPlaces` is reset to `2`, and `isCurrencyFeminine` ' is set to `False` by default. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub CleanUpVariables() ' Clean up ' Currency Information By Arabic CurrencyNameSingular = vbNullString CurrencyNameDual = vbNullString CurrencyNamePlural = vbNullString CurrencyNameAccusative = vbNullString FractionalUnitSingular = vbNullString FractionalUnitDual = vbNullString FractionalUnitPlural = vbNullString FractionalUnitAccusative = vbNullString ' Currency Information By Other Language CurrencyNameSingularOtherLang = vbNullString CurrencyNameDualOtherLang = vbNullString CurrencyNamePluralOtherLang = vbNullString CurrencyNameAccusativeOtherLang = vbNullString FractionalUnitSingularOtherLang = vbNullString FractionalUnitDualOtherLang = vbNullString FractionalUnitPluralOtherLang = vbNullString FractionalUnitAccusativeOtherLang = vbNullString CurrencyISOCode = vbNullString NumberOfDecimalPlaces = 2 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 End Sub ' Constants of names of common currency fractions with more than one currency '********************************************************************** ' Function: Piastre ' Purpose: Returns the correct string representation of a fractional currency unit (Piastre) ' based on the input integer value. ' Inputs: num - Integer value representing the type of fractional unit. ' Outputs: None. ' Returns: String - The corresponding string representation of the fractional unit in Arabic or English. ' Notes: - The function uses Select Case to determine the appropriate string based on the input number. ' - The first four cases correspond to Arabic representations using character codes. ' - The last four cases correspond to English representations of the Piastre unit. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function Piastre(Num As Integer) Dim FractionalUnit As String: FractionalUnit = "Piastre" Select Case Num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(222) & Chr(209) & Chr(212) Case Is = 2: FractionalUnit = Chr(222) & Chr(209) & Chr(212) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(222) & Chr(209) & Chr(230) & Chr(212) Case Is = 4: FractionalUnit = Chr(222) & Chr(209) & Chr(212) & Chr(199) & Chr(240) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Piastre" Case Is = 6: FractionalUnit = "Two Piastres" Case Is = 7: FractionalUnit = "Piastres" Case Is = 8: FractionalUnit = "One Piastre" End Select Piastre = FractionalUnit End Function Public Function Dirham(Num As Integer) Dim FractionalUnit As String: FractionalUnit = "Dirham" Select Case Num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) Case Is = 2: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) Case Is = 3: FractionalUnit = Chr(207) & Chr(209) & Chr(199) & Chr(229) & Chr(227) Case Is = 4: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Dirham" Case Is = 6: FractionalUnit = "Two Dirhams" Case Is = 7: FractionalUnit = "Dirhams" Case Is = 8: FractionalUnit = "One Dirham" End Select Dirham = FractionalUnit End Function Public Function Fils(Num As Integer) Dim FractionalUnit As String: FractionalUnit = "Fils" Select Case Num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(221) & Chr(225) & Chr(211) Case Is = 2: FractionalUnit = Chr(221) & Chr(225) & Chr(211) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(221) & Chr(225) & Chr(230) & Chr(211) Case Is = 4: FractionalUnit = Chr(221) & Chr(225) & Chr(211) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Fils" Case Is = 6: FractionalUnit = "Two Fils" Case Is = 7: FractionalUnit = "Fils" Case Is = 8: FractionalUnit = "One Fils" End Select Fils = FractionalUnit End Function Public Function Centime(Num As Integer) Dim FractionalUnit As String: FractionalUnit = "Centime" Select Case Num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) Case Is = 2: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(202) Case Is = 4: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(240) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Centime" Case Is = 6: FractionalUnit = "Two Centimes" Case Is = 7: FractionalUnit = "Centimes" Case Is = 8: FractionalUnit = "One Centime" End Select Centime = FractionalUnit End Function Public Function Cent(Num As Integer) Dim FractionalUnit As String: FractionalUnit = "Cent" Select Case Num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(211) & Chr(228) & Chr(202) Case Is = 2: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(199) & Chr(202) Case Is = 4: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Cent" Case Is = 6: FractionalUnit = "Two Cents" Case Is = 7: FractionalUnit = "Cents" Case Is = 8: FractionalUnit = "One Cent" End Select Cent = FractionalUnit End Function '********************************************************************** ' Subroutine: UpdateCurrencyTable ' Purpose: Updates the tblCurrencyInfo table with currency information. ' Inputs: None. ' Outputs: None. ' Returns: None. ' Notes: - Retrieves an array of currency data and inserts or updates records in the database. ' - The function uses dynamic SQL to insert records into the table. ' - The `CurrencyYouWantToBeActive` function should return the currency that should be marked as active. ' - The `GetEgyptianPound`, `GetSaudiRiyal`, etc., functions should return currency information in a defined format. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub UpdateCurrencyTable() Dim db As DAO.Database Dim sql As String Dim sqlStart As String Dim sqlValues As String Dim currencies As Variant Dim i As Integer Dim activeCurrency As String ' Obtain a reference to the current database Set db = CurrentDb() ' Define the currency that should be active activeCurrency = CurrencyYouWantToBeActive() ' Replace with the name of the currency you want to be active ' Define an array of currencies with their respective values in Arabic and English, and active status currencies = Array( _ GetEgyptianPound(), _ GetSaudiRiyal(), _ GetQatariRiyal(), _ GetOmaniRial(), _ GetBahrainiDinar(), _ GetMoroccanDirham(), _ GetTunisianDinar(), _ GetAlgerianDinar(), _ GetIraqiDinar()) ' SQL statement parts sqlStart = "INSERT INTO tblCurrencyInfo " & _ "([IsCurrencyActive], [CurrencyNameSingular], [CurrencyNameDual], [CurrencyNamePlural], [CurrencyNameAccusative], [CurrencyBaseValue], " & _ "[FractionalUnitSingular], [FractionalUnitDual], [FractionalUnitPlural], [FractionalUnitAccusative], [FractionalUnitBaseValue], " & _ "[CurrencyNameSingularOtherLang], [CurrencyNameDualOtherLang], [CurrencyNamePluralOtherLang], [CurrencyNameAccusativeOtherLang], [CurrencyBaseValueOtherLang], " & _ "[FractionalUnitSingularOtherLang], [FractionalUnitDualOtherLang], [FractionalUnitPluralOtherLang], [FractionalUnitAccusativeOtherLang], [FractionalUnitBaseValueOtherLang], " & _ "[CurrencyISOCode], [NumberOfDecimalPlaces], [isCurrencyFeminine]) " & _ "VALUES (" ' Iterate through the array and insert each record into the table For i = LBound(currencies) To UBound(currencies) ' Debug: Print index and values for inspection ' Dim j As Integer ' Debug.Print "currencies(" & i & ")(" & j & "): " & currencies(i)(j) ' Debug.Print "Processing row " & i ' Construct the VALUES part of the SQL statement sqlValues = IIf(currencies(i)(0) = activeCurrency, "True", "False") & ", " & _ "'" & currencies(i)(0) & "', " & _ "'" & currencies(i)(1) & "', " & _ "'" & currencies(i)(2) & "', " & _ "'" & currencies(i)(3) & "', " & _ "'" & currencies(i)(4) & "', " & _ "'" & Nz(currencies(i)(5)) & "', " & _ "'" & Nz(currencies(i)(6)) & "', " & _ "'" & Nz(currencies(i)(7)) & "', " & _ "'" & Nz(currencies(i)(8)) & "', " & _ "'" & currencies(i)(9) & "', " & _ "'" & currencies(i)(10) & "', " & _ "'" & currencies(i)(11) & "', " & _ "'" & currencies(i)(12) & "', " & _ "'" & currencies(i)(13) & "', " & _ "'" & currencies(i)(14) & "', " & _ "'" & currencies(i)(15) & "', " & _ "'" & currencies(i)(16) & "', " & _ "'" & currencies(i)(17) & "', " & _ "'" & currencies(i)(18) & "', " & _ "'" & currencies(i)(19) & "', " & _ "'" & currencies(i)(20) & "', " & _ "'" & currencies(i)(21) & "', " & _ IIf(currencies(i)(22), "True", "False") ' Set isCurrencyFeminine value ' Combine SQL parts sql = sqlStart & sqlValues & ");" ' Debug: Print the SQL statement for inspection ' Debug.Print sql ' Execute the SQL statement db.Execute sql Next i ' Clean up sqlStart = "" Set db = Nothing End Sub ' array '********************************************************************** ' Function: GetEgyptianPound ' Purpose: Returns an array containing detailed information about the Egyptian Pound in both Arabic and English. ' Inputs: None. ' Outputs: None. ' Returns: Variant - An array containing: ' [0] - CurrencyNameSingular (Arabic) ' [1] - CurrencyNameDual (Arabic) ' [2] - CurrencyNamePlural (Arabic) ' [3] - CurrencyNameAccusative (Arabic) ' [4] - CurrencyBaseValue (Arabic) ' [5] - FractionalUnitSingular (Arabic) ' [6] - FractionalUnitDual (Arabic) ' [7] - FractionalUnitPlural (Arabic) ' [8] - FractionalUnitAccusative (Arabic) ' [9] - FractionalUnitBaseValue (Arabic) ' [10] - CurrencyNameSingularOtherLang (English) ' [11] - CurrencyNameDualOtherLang (English) ' [12] - CurrencyNamePluralOtherLang (English) ' [13] - CurrencyNameAccusativeOtherLang (English) ' [14] - CurrencyBaseValue (English) ' [15] - FractionalUnitSingularOtherLang (English) ' [16] - FractionalUnitDualOtherLang (English) ' [17] - FractionalUnitPluralOtherLang (English) ' [18] - FractionalUnitAccusativeOtherLang (English) ' [19] - FractionalUnitBaseValue (English) ' [20] - CurrencyISOCode (EGP) ' [21] - NumberOfDecimalPlaces (2) ' [22] - isCurrencyFeminine (Boolean) ' Notes: - The function utilizes `Piastre` to obtain the fractional unit names. ' - The `CleanUpVariables` subroutine is called at the end to reset the variables. ' - The returned array is structured for easy insertion into a database or use in other calculations. '********************************************************************** ' Author: Mohammed Essam, www.officena.net ' Contact: soul-angel@msn.com ' Date: August 2024 '********************************************************************** Function GetEgyptianPound() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) CurrencyNameDual = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(228) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(202) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(240) & Chr(199) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Piastre(1) FractionalUnitDual = Piastre(2) FractionalUnitPlural = Piastre(3) FractionalUnitAccusative = Piastre(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Egyptian Pound" CurrencyNameDualOtherLang = "Two Egyptian Pounds" CurrencyNamePluralOtherLang = "Egyptian Pounds" CurrencyNameAccusativeOtherLang = "One Egyptian Pound" FractionalUnitSingularOtherLang = Piastre(5) FractionalUnitDualOtherLang = Piastre(6) FractionalUnitPluralOtherLang = Piastre(7) FractionalUnitAccusativeOtherLang = Piastre(8) CurrencyISOCode = "EGP" NumberOfDecimalPlaces = 2 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetEgyptianPound = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetSaudiRiyal() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) CurrencyNameDual = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(228) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(202) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(240) & Chr(199) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Chr(229) & Chr(225) & Chr(225) & Chr(201) FractionalUnitDual = Chr(229) & Chr(225) & Chr(225) & Chr(202) & Chr(199) & Chr(228) FractionalUnitPlural = Chr(229) & Chr(225) & Chr(225) & Chr(199) & Chr(202) FractionalUnitAccusative = Chr(229) & Chr(225) & Chr(225) & Chr(201) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Saudi Riyal" CurrencyNameDualOtherLang = "Two Saudi Riyals" CurrencyNamePluralOtherLang = "Saudi Riyals" CurrencyNameAccusativeOtherLang = "One Saudi Riyal" FractionalUnitSingularOtherLang = "Halala" FractionalUnitDualOtherLang = "Two Halalas" FractionalUnitPluralOtherLang = "Halalas" FractionalUnitAccusativeOtherLang = "One Halala" CurrencyISOCode = "SAR" NumberOfDecimalPlaces = 2 isCurrencyFeminine = True CurrencyBaseValue = 1 FractionalUnitBaseValue = 0 GetSaudiRiyal = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetQatariRiyal() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(222) & Chr(216) & Chr(209) & Chr(237) CurrencyNameDual = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(228) & Chr(32) & Chr(222) & Chr(216) & Chr(209) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(202) & Chr(32) & Chr(222) & Chr(216) & Chr(209) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(240) & Chr(199) & Chr(32) & Chr(222) & Chr(216) & Chr(209) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Dirham(1) FractionalUnitDual = Dirham(2) FractionalUnitPlural = Dirham(3) FractionalUnitAccusative = Dirham(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Qatari Riyal" CurrencyNameDualOtherLang = "Two Qatari Riyals" CurrencyNamePluralOtherLang = "Qatari Riyals" CurrencyNameAccusativeOtherLang = "One Qatari Riyal" FractionalUnitSingularOtherLang = Dirham(5) FractionalUnitDualOtherLang = Dirham(6) FractionalUnitPluralOtherLang = Dirham(7) FractionalUnitAccusativeOtherLang = Dirham(8) CurrencyISOCode = "QAR" NumberOfDecimalPlaces = 2 isCurrencyFeminine = False CurrencyBaseValue = 1 FractionalUnitBaseValue = 0 GetQatariRiyal = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetBahrainiDinar() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(32) & Chr(200) & Chr(205) & Chr(209) & Chr(237) & Chr(228) & Chr(237) CurrencyNameDual = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(228) & Chr(32) & Chr(200) & Chr(205) & Chr(209) & Chr(237) & Chr(228) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(207) & Chr(228) & Chr(199) & Chr(228) & Chr(237) & Chr(209) & Chr(32) & Chr(200) & Chr(205) & Chr(209) & Chr(237) & Chr(228) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(240) & Chr(199) & Chr(32) & Chr(200) & Chr(205) & Chr(209) & Chr(237) & Chr(228) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Fils(1) FractionalUnitDual = Fils(2) FractionalUnitPlural = Fils(3) FractionalUnitAccusative = Fils(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Bahraini Dinar" CurrencyNameDualOtherLang = "Two Bahraini Dinars" CurrencyNamePluralOtherLang = "Bahraini Dinars" CurrencyNameAccusativeOtherLang = "One Bahraini Dinar" FractionalUnitSingularOtherLang = Fils(5) FractionalUnitDualOtherLang = Fils(6) FractionalUnitPluralOtherLang = Fils(7) FractionalUnitAccusativeOtherLang = Fils(8) CurrencyISOCode = "BHD" NumberOfDecimalPlaces = 3 isCurrencyFeminine = False CurrencyBaseValue = 1 FractionalUnitBaseValue = 0 GetBahrainiDinar = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetOmaniRial() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(218) & Chr(227) & Chr(199) & Chr(228) & Chr(237) CurrencyNameDual = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(228) & Chr(32) & Chr(218) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(202) & Chr(32) & Chr(218) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(240) & Chr(199) & Chr(32) & Chr(218) & Chr(227) & Chr(199) & Chr(228) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Chr(200) & Chr(237) & Chr(211) & Chr(201) FractionalUnitDual = Chr(200) & Chr(237) & Chr(211) & Chr(202) & Chr(199) & Chr(228) FractionalUnitPlural = Chr(200) & Chr(237) & Chr(211) & Chr(199) & Chr(202) FractionalUnitAccusative = Chr(200) & Chr(237) & Chr(211) & Chr(201) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Omani Rial" CurrencyNameDualOtherLang = "Two Omani Rials" CurrencyNamePluralOtherLang = "Omani Rials" CurrencyNameAccusativeOtherLang = "One Omani Rial" FractionalUnitSingularOtherLang = "Baisa" FractionalUnitDualOtherLang = "Two Baisas" FractionalUnitPluralOtherLang = "Baisas" FractionalUnitAccusativeOtherLang = "One Baisa|" CurrencyISOCode = "OMR" NumberOfDecimalPlaces = 3 isCurrencyFeminine = True CurrencyBaseValue = 1 FractionalUnitBaseValue = 0 GetOmaniRial = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetMoroccanDirham() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(207) & Chr(209) & Chr(229) & Chr(227) & Chr(32) & Chr(227) & Chr(219) & Chr(209) & Chr(200) & Chr(237) CurrencyNameDual = Chr(207) & Chr(209) & Chr(229) & Chr(227) & Chr(199) & Chr(228) & Chr(32) & Chr(227) & Chr(219) & Chr(209) & Chr(200) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(207) & Chr(209) & Chr(199) & Chr(229) & Chr(227) & Chr(32) & Chr(227) & Chr(219) & Chr(209) & Chr(200) & Chr(237) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(207) & Chr(209) & Chr(229) & Chr(227) & Chr(199) & Chr(240) & Chr(32) & Chr(227) & Chr(219) & Chr(209) & Chr(200) & Chr(237) & Chr(199) & Chr(240) FractionalUnitSingular = Centime(1) FractionalUnitDual = Centime(2) FractionalUnitPlural = Centime(3) FractionalUnitAccusative = Centime(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Moroccan Dirham" CurrencyNameDualOtherLang = "Two Moroccan Dirhams" CurrencyNamePluralOtherLang = "Moroccan Dirhams" CurrencyNameAccusativeOtherLang = "One Moroccan Dirham" FractionalUnitSingularOtherLang = Centime(5) FractionalUnitDualOtherLang = Centime(6) FractionalUnitPluralOtherLang = Centime(7) FractionalUnitAccusativeOtherLang = Centime(8) CurrencyISOCode = "MAD" NumberOfDecimalPlaces = 2 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetMoroccanDirham = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetTunisianDinar() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(32) & Chr(202) & Chr(230) & Chr(228) & Chr(211) & Chr(237) CurrencyNameDual = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(228) & Chr(32) & Chr(202) & Chr(230) & Chr(228) & Chr(211) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(207) & Chr(228) & Chr(199) & Chr(228) & Chr(237) & Chr(209) & Chr(32) & Chr(202) & Chr(230) & Chr(228) & Chr(211) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(240) & Chr(32) & Chr(202) & Chr(230) & Chr(228) & Chr(211) & Chr(237) & Chr(199) & Chr(240) FractionalUnitSingular = Chr(227) & Chr(225) & Chr(237) & Chr(227) FractionalUnitDual = Chr(227) & Chr(225) & Chr(237) & Chr(227) & Chr(199) & Chr(228) FractionalUnitPlural = Chr(227) & Chr(225) & Chr(237) & Chr(227) & Chr(199) & Chr(202) FractionalUnitAccusative = Chr(227) & Chr(225) & Chr(237) & Chr(227) & Chr(199) & Chr(240) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Tunisian Dinar" CurrencyNameDualOtherLang = "Two Tunisian Dinars" CurrencyNamePluralOtherLang = "Tunisian Dinars" CurrencyNameAccusativeOtherLang = "One Tunisian Dinar" FractionalUnitSingularOtherLang = "Millime" FractionalUnitDualOtherLang = "Two Millimes" FractionalUnitPluralOtherLang = "Millimes" FractionalUnitAccusativeOtherLang = "One Millime" CurrencyISOCode = "TND" NumberOfDecimalPlaces = 3 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetTunisianDinar = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetAlgerianDinar() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(32) & Chr(204) & Chr(210) & Chr(199) & Chr(198) & Chr(209) & Chr(237) CurrencyNameDual = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(228) & Chr(32) & Chr(204) & Chr(210) & Chr(199) & Chr(198) & Chr(209) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(207) & Chr(228) & Chr(199) & Chr(228) & Chr(237) & Chr(209) & Chr(32) & Chr(204) & Chr(210) & Chr(199) & Chr(198) & Chr(209) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(240) & Chr(32) & Chr(204) & Chr(210) & Chr(199) & Chr(198) & Chr(209) & Chr(237) & Chr(199) & Chr(240) FractionalUnitSingular = Chr(32) FractionalUnitDual = Chr(32) FractionalUnitPlural = Chr(32) FractionalUnitAccusative = Chr(32) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Algerian Dinar" CurrencyNameDualOtherLang = "Two Algerian Dinars" CurrencyNamePluralOtherLang = "Algerian Dinars" CurrencyNameAccusativeOtherLang = "One Algerian Dinar" FractionalUnitSingularOtherLang = Chr(32) FractionalUnitDualOtherLang = Chr(32) FractionalUnitPluralOtherLang = Chr(32) FractionalUnitAccusativeOtherLang = Chr(32) CurrencyISOCode = "DZD" NumberOfDecimalPlaces = 0 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetAlgerianDinar = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function Function GetIraqiDinar() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(32) & Chr(218) & Chr(209) & Chr(199) & Chr(222) & Chr(237) CurrencyNameDual = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(228) & Chr(32) & Chr(218) & Chr(209) & Chr(199) & Chr(222) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(207) & Chr(228) & Chr(199) & Chr(228) & Chr(237) & Chr(209) & Chr(32) & Chr(218) & Chr(209) & Chr(199) & Chr(222) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(207) & Chr(237) & Chr(228) & Chr(199) & Chr(209) & Chr(199) & Chr(240) & Chr(32) & Chr(218) & Chr(209) & Chr(199) & Chr(222) & Chr(237) & Chr(199) & Chr(240) FractionalUnitSingular = Fils(1) FractionalUnitDual = Fils(2) FractionalUnitPlural = Fils(3) FractionalUnitAccusative = Fils(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Iraqi Dinar" CurrencyNameDualOtherLang = "Two Iraqi Dinars" CurrencyNamePluralOtherLang = "Iraqi Dinars" CurrencyNameAccusativeOtherLang = "One Iraqi Dinar" FractionalUnitSingularOtherLang = Fils(5) FractionalUnitDualOtherLang = Fils(6) FractionalUnitPluralOtherLang = Fils(7) FractionalUnitAccusativeOtherLang = Fils(8) CurrencyISOCode = "IQD" NumberOfDecimalPlaces = 3 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetIraqiDinar = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function الوظيفبة الأولى : TableExists الغرض منها التحقق من وجود الجدول وفى حالة وجودة سوف يتم تجاهل دوال انشاء الجدول او اضافة البيانات الاساسية اليه. الوظيفبة التالية : CreateCurrencyTable الغرض منها إنشاء جدول جديد باسم "tblCurrencyInfo" مع حقول محددة مسبقًا في قاعدة البيانات الحالية ملاحظات: تقوم هذا الوظيفة الفرعية بتهيئة جدول جديد وتحديد الحقول الضرورية لتخزين معلومات العملات حيث تتضمن الحقول معلومات العملة القياسية والخاصة باللغة كما سيتم توضيحه . عند انشاء الجدول اضفت اكواد لتعديل خصائص الحقل بوضع التسمية المناسبة لكل حقل وكذلك الوصف تم تشفير كل الأحرف العربية داخل الوحدة النمطية لتكون بالـ Ascii وذلك حتى يتم التعرف على الحروف فى اى حاسوب بغض النظر عن اعدادات اللغة المستخدمة لمنع مشاكل اللغة والتى تعيق البعض من استخدام الاكواد ولذلك سوف اضع المرفق الاخر وهى اداة كنت قد قمت بتصميمها قبل فترة لتعمل على التحويل من والى الـ Ascii الوظيفبة التالية : CreateAndUpdateCurrencyTable الغرض منها استدعاء دوال انشاء الجدول ةإضافة ببيانات العملات لا اكثر ولا اقل من ذلك . الوظيفبة التالية : GetCurrencyValues الغرض منها استرداد قيم العملات من جدول "tblCurrencyInfo" استنادًا إلى العملة النشطة و المحددة للاستخدام من خلال الكود . المدخلات: اللغة اختيارية كسلسلة - "ar" (افتراضي) للغة العربية و"EN" للغة الإنجليزية الإرجاع: مجموعة من قيم العملات باللغة المحددة ملاحظات: - تتحقق الوظيفة مما إذا كان جدول "tblCurrencyInfo" موجودًا ومملوءًا بالعملات وبالاخص العملة النشطة - إذا لم يتم العثور على سجلات نشطة فإنها ترجع مجموعة من القيم الافتراضية - تعالج أخطاء الجدول المفقودة عن طريق استدعاء الدالة CreateAndUpdateCurrencyTable الوظيفبة التالية : ConvertToWords الغرض منها تحويل سلسلة رقمية إلى كلمات باللغة العربية أو الإنجليزية المدخلات: num - القيمة الرقمية كسلسلة currencyTerms - مجموعة من مصطلحات العملة للتحويل lang اختياري - لغة الهدف للتحويل (الإعداد الافتراضي هو "ar") الإرجاع: String - القيمة الرقمية بالكلمات ملاحظات: تدعم الوظيفة اللغتين الإنجليزية والعربية يتم تضمين النص العربي للوحدات الصغيرة ( كسر العملة) والوحدات الكبيرة لتحويل العملات وهى دالة مساعدة للدالة الاساسية التى يتم استدعائها وتتعامل بحرفية تامة مع كسر العملات حسب النوع الذكورى منها والانثوى الوظيفبة التالية : ConvertNumberToWords الغرض: تحويل سلسلة رقمية إلى تمثيلها اللفظي باللغة العربية أو الإنجليزية فهى الدالة الاساسية والتى ييتم استدعائها لاجراء عملية التحويل والتفقيط المدخلات: الرقم - القيمة الرقمية كسلسلة اللغة الاختيارية - اللغة المستهدفة للتحويل (الإعداد الافتراضي هو "ar") الإرجاع: السلسلة - القيمة الرقمية بالكلمات بتمثيلها اللفظي باللغة العربية أو الإنجليزية الملاحظات: يتم التعامل مع كل من الأجزاء الصحيحة و الكسرية للعملة ( العدد الرقمى) الوظيفبة التالية : CleanUpVariables الغرض منها منع تكرار الاكواد فقط ووظيفتها تفريغ قيم المتتغيرات بغرض تنظيف الذاكرة اما هذه الوظائف الاتية ' Constants of names of common currency fractions with more than one currency Public Function Piastre(num As Integer) Dim FractionalUnit As String: FractionalUnit = "Piastre" Select Case num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(222) & Chr(209) & Chr(212) Case Is = 2: FractionalUnit = Chr(222) & Chr(209) & Chr(212) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(222) & Chr(209) & Chr(230) & Chr(212) Case Is = 4: FractionalUnit = Chr(222) & Chr(209) & Chr(212) & Chr(199) & Chr(240) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Piastre" Case Is = 6: FractionalUnit = "Two Piastres" Case Is = 7: FractionalUnit = "Piastres" Case Is = 8: FractionalUnit = "One Piastre" End Select Piastre = FractionalUnit End Function Public Function Dirham(num As Integer) Dim FractionalUnit As String: FractionalUnit = "Dirham" Select Case num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) Case Is = 2: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) Case Is = 3: FractionalUnit = Chr(207) & Chr(209) & Chr(199) & Chr(229) & Chr(227) Case Is = 4: FractionalUnit = Chr(207) & Chr(209) & Chr(229) & Chr(227) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Dirham" Case Is = 6: FractionalUnit = "Two Dirhams" Case Is = 7: FractionalUnit = "Dirhams" Case Is = 8: FractionalUnit = "One Dirham" End Select Dirham = FractionalUnit End Function Public Function Fils(num As Integer) Dim FractionalUnit As String: FractionalUnit = "Fils" Select Case num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(221) & Chr(225) & Chr(211) Case Is = 2: FractionalUnit = Chr(221) & Chr(225) & Chr(211) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(221) & Chr(225) & Chr(230) & Chr(211) Case Is = 4: FractionalUnit = Chr(221) & Chr(225) & Chr(211) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Fils" Case Is = 6: FractionalUnit = "Two Fils" Case Is = 7: FractionalUnit = "Fils" Case Is = 8: FractionalUnit = "One Fils" End Select Fils = FractionalUnit End Function Public Function Centime(num As Integer) Dim FractionalUnit As String: FractionalUnit = "Centime" Select Case num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) Case Is = 2: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(202) Case Is = 4: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(237) & Chr(227) & Chr(199) & Chr(240) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Centime" Case Is = 6: FractionalUnit = "Two Centimes" Case Is = 7: FractionalUnit = "Centimes" Case Is = 8: FractionalUnit = "One Centime" End Select Centime = FractionalUnit End Function Public Function Cent(num As Integer) Dim FractionalUnit As String: FractionalUnit = "Cent" Select Case num ' Currency Information By Arabic Case Is = 1: FractionalUnit = Chr(211) & Chr(228) & Chr(202) Case Is = 2: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(199) & Chr(228) Case Is = 3: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(199) & Chr(202) Case Is = 4: FractionalUnit = Chr(211) & Chr(228) & Chr(202) & Chr(240) & Chr(199) ' Currency Information By Other Language Case Is = 5: FractionalUnit = "Cent" Case Is = 6: FractionalUnit = "Two Cents" Case Is = 7: FractionalUnit = "Cents" Case Is = 8: FractionalUnit = "One Cent" End Select Cent = FractionalUnit End Function هى وظائف مساعدة لوظائف إضافة بيانات العملات داخل الجدول عند انشائه للمرة الاولى ملحوظة هامة : هى تخص فقط اجزاء العملات ( كسر العملة ) الطبيعى ان هذا الجزء موجود فى وظائف العملات ولكن اسم هذا الجزء ( كسر العملة ) لكل عملة هو مشترك بين العديد من العملات فبدلا من كثرة الكتابة وتكرار الاكواد قمت بفصلها على ان تكون وظائف مشتركة لتكتب مرة واحدة ولكن يتم استدعائها عند الحاجة مع العملات المشتركة مثل : فلس فهو يشترك مع كل من العملات الاتية دينار بحريني , دينار عراقي هذا على سبيل المثال وليس الحصر الان وصلنا الى الجزء الاخير الوظيفبة التالية : UpdateCurrencyTable الغرض منها : إضافة بيانات العملات الى الجدول هذه الدالة عبارة عن مصفوفة رئيسية متضمنة بداخلها مصفوفات فرعية كان شكل الكود كالتالى عندما كتبته فى المرة الاول Sub UpdateCurrencyTable() Dim db As DAO.Database Dim sql As String Dim currencies As Variant Dim i As Integer ' Obtain a reference to the current database Set db = CurrentDb() ' Define an array of currencies with their respective values in Arabic and English, and active status currencies = Array(Array("جنيه مصري", "جنيهان مصريان", "جنيهات مصرية", "جنيهًا مصريًا", "0", "قرش", "قرشان", "قروش", "قرشًا", "0", "Egyptian Pound", "Two Egyptian Pounds", "Egyptian Pounds", "One Egyptian Pound", "0", "Piastre", "Two Piastres", "Piastres", "One Piastre", "0", "EGP", 2, True), _ Array("دينار أردني", "ديناران أردنيان", "دنانير أردنية", "دينار أردني", "1", "قرش", "قرشان", "قروش", "قرش", "0", "Jordanian Dinar", "Two Jordanian Dinars", "Jordanian Dinars", "One Jordanian Dinar", "1", "Piastre", "Two Piastres", "Piastres", "One Piastre", "0", "JOD", 3, False), _ Array("دينار كويتي", "ديناران كويتيان", "دنانير كويتية", "دينار كويتي", "1", "فلس", "فلسان", "فلسات", "فلس", "0", "Kuwaiti Dinar", "Two Kuwaiti Dinars", "Kuwaiti Dinars", "One Kuwaiti Dinar", "1", "Fils", "Two Fils", "Fils", "One Fils", "0", "KWD", 3, False), _ Array("ريال سعودي", "ريالان سعوديان", "ريالات سعودية", "ريال سعودي", "1", "هللة", "هللتان", "هللات", "هللة", "0", "Saudi Riyal", "Two Saudi Riyals", "Saudi Riyals", "One Saudi Riyal", "1", "Halala", "Two Halalas", "Halalas", "One Halala", "0", "SAR", 2, False), _ Array("درهم إماراتي", "درهمان إماراتيان", "درهمات إماراتية", "درهم إماراتي", "1", "فلس", "فلسان", "فلسات", "فلس", "0", "UAE Dirham", "Two UAE Dirhams", "UAE Dirhams", "One UAE Dirham", "1", "Fils", "Two Fils", "Fils", "One Fils", "0", "AED", 2, False), _ Array("ريال قطري", "ريالان قطريان", "ريالات قطرية", "ريال قطري", "1", "درهم", "درهمان", "درهمات", "درهم", "0", "Qatari Riyal", "Two Qatari Riyals", "Qatari Riyals", "One Qatari Riyal", "1", "Dirham", "Two Dirhams", "Dirhams", "One Dirham", "0", "QAR", 2, False), _ Array("دينار بحريني", "ديناران بحرينيان", "دنانير بحرينية", "دينار بحريني", "1", "فلس", "فلسان", "فلسات", "فلس", "0", "Bahraini Dinar", "Two Bahraini Dinars", "Bahraini Dinars", "One Bahraini Dinar", "1", "Fils", "Two Fils", "Fils", "One Fils", "0", "BHD", 3, False), _ Array("ريال عماني", "ريالان عمانيان", "ريالات عمانية", "ريال عماني", "1", "بيسة", "بيستان", "بيسات", "بيسة", "0", "Omani Rial", "Two Omani Rials", "Omani Rials", "One Omani Rial", "1", "Baisa", "Two Baisas", "Baisas", "One Baisa", "0", "OMR", 3, False), _ Array("دولار أمريكي", "دولارين أمريكيين", "دولارات أمريكية", "دولار أمريكي", "1", "سنت", "سنتان", "سنتات", "سنت", "0", "US Dollar", "Two US Dollars", "US Dollars", "One US Dollar", "1", "Cent", "Two Cents", "Cents", "One Cent", "0", "USD", 2, False), _ Array("يورو", "يوروين", "يوروهات", "يورو", "1", "سنت", "سنتان", "سنتات", "سنت", "0", "Euro", "Two Euros", "Euros", "One Euro", "1", "Cent", "Two Cents", "Cents", "One Cent", "0", "EUR", 2, False), _ Array("جنيه إسترليني", "جنيهان إسترلينيان", "جنيهات إسترلينية", "جنيه إسترليني", "1", "بيني", "بينيان", "بنسات", "بيني", "0", "British Pound", "Two British Pounds", "British Pounds", "One British Pound", "1", "Penny", "Two Pennies", "Pennies", "One Penny", "0", "GBP", 2, False), _ Array("ين ياباني", "ينان يابانيان", "ينات يابانية", "ين ياباني", "1", "سين", "سنان", "سينات", "سين", "0", "Japanese Yen", "Two Japanese Yens", "Japanese Yens", "One Japanese Yen", "1", "Sen", "Two Sens", "Sens", "One Sen", "0", "JPY", 0, False), _ Array("دولار كندي", "دولارين كنديين", "دولارات كندية", "دولار كندي", "1", "سنت", "سنتان", "سنتات", "سنت", "0", "Canadian Dollar", "Two Canadian Dollars", "Canadian Dollars", "One Canadian Dollar", "1", "Cent", "Two Cents", "Cents", "One Cent", "0", "CAD", 2, False), _ Array("دولار أسترالي", "دولارين أستراليين", "دولارات أسترالية", "دولار أسترالي", "1", "سنت", "سنتان", "سنتات", "سنت", "0", "Australian Dollar", "Two Australian Dollars", "Australian Dollars", "One Australian Dollar", "1", "Cent", "Two Cents", "Cents", "One Cent", "0", "AUD", 2, False), _ Array("فرنك سويسري", "فرنكان سويسريان", "فرنكات سويسرية", "فرنك سويسري", "1", "رابن", "رابنان", "رابنات", "رابن", "0", "Swiss Franc", "Two Swiss Francs", "Swiss Francs", "One Swiss Franc", "1", "Rappen", "Two Rappen", "Rappen", "One Rappen", "0", "CHF", 2, False), _ Array("يوان صيني", "يوانان صينيان", "يوانات صينية", "يوان صيني", "1", "فن", "فنان", "فنانات", "فن", "0", "Chinese Yuan", "Two Chinese Yuan", "Chinese Yuan", "One Chinese Yuan", "1", "Fen", "Two Fens", "Fens", "One Fen", "0", "CNY", 2, False), _ Array("كرونة سويدية", "كرونتان سويديان", "كرونات سويدية", "كرونة سويدية", "1", "أوره", "أورهات", "أورهات", "أوره", "0", "Swedish Krona", "Two Swedish Kronor", "Swedish Kronor", "One Swedish Krona", "1", "Kr", "Two Kr", "Kronor", "One Kr", "0", "SEK", 2, False), _ Array("دولار نيوزيلندي", "دولارين نيوزيلنديين", "دولارات نيوزيلندية", "دولار نيوزيلندي", "1", "سنت", "سنتان", "سنتات", "سنت", "0", "New Zealand Dollar", "Two New Zealand Dollars", "New Zealand Dollars", "One New Zealand Dollar", "1", "Cent", "Two Cents", "Cents", "One Cent", "0", "NZD", 2, False)) ' Iterate through the array and insert each record into the table For i = LBound(currencies) To UBound(currencies) sql = "INSERT INTO tblCurrencyInfo ([CurrencyNameSingular], [CurrencyNameDual], [CurrencyNamePlural], [CurrencyNameAccusative], [CurrencyBaseValue], [PiastreNameSingular], [PiastreNameDual], [PiastreNamePlural], [PiastreNameAccusative], [PiastreBaseValue], " & _ "[CurrencyNameSingularOtherLang], [CurrencyNameDualOtherLang], [CurrencyNamePluralOtherLang], [CurrencyNameAccusativeOtherLang], [CurrencyBaseValueOtherLang], [PiastreNameSingularOtherLang], [PiastreNameDualOtherLang], [PiastreNamePluralOtherLang], [PiastreNameAccusativeOtherLang], [PiastreBaseValueOtherLang], [CurrencyISOCode], [NumberOfDecimalPlaces], [IsCurrencyActive]) " & _ "VALUES ('" & currencies(i)(0) & "', '" & currencies(i)(1) & "', '" & currencies(i)(2) & "', '" & currencies(i)(3) & "', '" & currencies(i)(4) & "', " & _ "'" & currencies(i)(5) & "', '" & currencies(i)(6) & "', '" & currencies(i)(7) & "', '" & currencies(i)(8) & "', '" & currencies(i)(9) & "', " & _ "'" & currencies(i)(10) & "', '" & currencies(i)(11) & "', '" & currencies(i)(12) & "', '" & currencies(i)(13) & "', '" & currencies(i)(14) & "', " & _ "'" & currencies(i)(15) & "', '" & currencies(i)(16) & "', '" & currencies(i)(17) & "', '" & currencies(i)(18) & "', '" & currencies(i)(19) & "', " & _ "'" & currencies(i)(20) & "', " & currencies(i)(21) & ", " & currencies(i)(22) & ");" db.Execute sql Next i ' Clean up Set db = Nothing End Sub وهنا كانت الفاجعة التحدى الاول و الأصعب لأنه فوجئت بشئ لم أكن أعلم عنه وهو أن الاكسس لا يمنحك عدد اسطر لا نهائية لكتابة اى وظيفة او روتين فوجئت ان هناك عدد من الاسطر محددة والتى لن يقبل منك محرر الاكواد اى شئ بعد الوصول اليها واستفاذ المجال المسموح به التحدى الثانى : دائما اتعب نفسي فى بداية تحليل النظام واكثر من ذلك عند كتابة الأكواد لأنه دائما وأبدا لا أفكر فى التعب عند وضع حجر الاساس فكل ما يشغل بالى ويهمنى هو المحصلة النهائية لتكون فى منتهى السهولة والمرونة اثناء التعامل مع المستخدم زى ما بيقول الفرنحة الـ End User لذلك كان التحدى هو كيف يتم تسهيل اضافة او تعديل العملات بالاضافة او بالحذف او بالتعديل طبعا الدالة السابقة وكما تشاهدون الموضوع صعب حبيتن و بما ان هذه مصفوفات لابد من التعامل معها بحذر فى الترتيب عند ادخال البينات التحدى الثالث : تحدى اكبر واصعب تشفير الحروف العربية الى Ascii وانا اقصد هنا بالأخص داخل المصفوفات لأنه سوف يزيد من حجم الكود وعدد الاسطر وبعد جهد وعناء شديدين فكرت فى فصل المصفوفات الفرعية للعملات على ان تكون لكل عملة مصفوفة خاصة بها ليتم كتابة كود المصوفة الرئيسية فى وظيفة منفصلة على ان يتم فيها فقط تجميع المصفوفات الفرعية للعملات من خلال استدعاء كل وظيفة وبذلك يكون كود المصفوفة الرئسية Sub UpdateCurrencyTable() Dim db As DAO.Database Dim sql As String Dim sqlStart As String Dim sqlValues As String Dim currencies As Variant Dim i As Integer Dim activeCurrency As String ' Obtain a reference to the current database Set db = CurrentDb() ' Define the currency that should be active activeCurrency = CurrencyYouWantToBeActive() ' Replace with the name of the currency you want to be active ' Define an array of currencies with their respective values in Arabic and English, and active status currencies = Array( _ GetEgyptianPound(), _ GetSaudiRiyal(), _ GetQatariRiyal(), _ GetOmaniRial(), _ GetBahrainiDinar(), _ GetMoroccanDirham(), _ GetTunisianDinar(), _ GetAlgerianDinar(), _ GetIraqiDinar()) ' SQL statement parts sqlStart = "INSERT INTO tblCurrencyInfo " & _ "([IsCurrencyActive], [CurrencyNameSingular], [CurrencyNameDual], [CurrencyNamePlural], [CurrencyNameAccusative], [CurrencyBaseValue], " & _ "[FractionalUnitSingular], [FractionalUnitDual], [FractionalUnitPlural], [FractionalUnitAccusative], [FractionalUnitBaseValue], " & _ "[CurrencyNameSingularOtherLang], [CurrencyNameDualOtherLang], [CurrencyNamePluralOtherLang], [CurrencyNameAccusativeOtherLang], [CurrencyBaseValueOtherLang], " & _ "[FractionalUnitSingularOtherLang], [FractionalUnitDualOtherLang], [FractionalUnitPluralOtherLang], [FractionalUnitAccusativeOtherLang], [FractionalUnitBaseValueOtherLang], " & _ "[CurrencyISOCode], [NumberOfDecimalPlaces], [isCurrencyFeminine]) " & _ "VALUES (" ' Iterate through the array and insert each record into the table For i = LBound(currencies) To UBound(currencies) ' Debug: Print index and values for inspection ' Dim j As Integer ' Debug.Print "currencies(" & i & ")(" & j & "): " & currencies(i)(j) ' Debug.Print "Processing row " & i ' Construct the VALUES part of the SQL statement sqlValues = IIf(currencies(i)(0) = activeCurrency, "True", "False") & ", " & _ "'" & currencies(i)(0) & "', " & _ "'" & currencies(i)(1) & "', " & _ "'" & currencies(i)(2) & "', " & _ "'" & currencies(i)(3) & "', " & _ "'" & currencies(i)(4) & "', " & _ "'" & Nz(currencies(i)(5)) & "', " & _ "'" & Nz(currencies(i)(6)) & "', " & _ "'" & Nz(currencies(i)(7)) & "', " & _ "'" & Nz(currencies(i)(8)) & "', " & _ "'" & currencies(i)(9) & "', " & _ "'" & currencies(i)(10) & "', " & _ "'" & currencies(i)(11) & "', " & _ "'" & currencies(i)(12) & "', " & _ "'" & currencies(i)(13) & "', " & _ "'" & currencies(i)(14) & "', " & _ "'" & currencies(i)(15) & "', " & _ "'" & currencies(i)(16) & "', " & _ "'" & currencies(i)(17) & "', " & _ "'" & currencies(i)(18) & "', " & _ "'" & currencies(i)(19) & "', " & _ "'" & currencies(i)(20) & "', " & _ "'" & currencies(i)(21) & "', " & _ IIf(currencies(i)(22), "True", "False") ' Set isCurrencyFeminine value ' Combine SQL parts sql = sqlStart & sqlValues & ");" ' Debug: Print the SQL statement for inspection ' Debug.Print sql ' Execute the SQL statement db.Execute sql Next i ' Clean up sqlStart = "" Set db = Nothing End Sub سنعود اليه قريبا.... الان المصفوفات الفرعية للعملات وهى هنا نوعان : النوع الاول : والذى يعتمد على اسماء كسر عملات مشتركة بين اكثر من عملة والتى تم التنويه عنها قبل قليل Function GetEgyptianPound() As Variant ' Currency Information By Arabic CurrencyNameSingular = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) CurrencyNameDual = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(228) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(199) & Chr(202) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(204) & Chr(228) & Chr(237) & Chr(229) & Chr(240) & Chr(199) & Chr(32) & Chr(227) & Chr(213) & Chr(209) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Piastre(1) FractionalUnitDual = Piastre(2) FractionalUnitPlural = Piastre(3) FractionalUnitAccusative = Piastre(4) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Egyptian Pound" CurrencyNameDualOtherLang = "Two Egyptian Pounds" CurrencyNamePluralOtherLang = "Egyptian Pounds" CurrencyNameAccusativeOtherLang = "One Egyptian Pound" FractionalUnitSingularOtherLang = Piastre(5) FractionalUnitDualOtherLang = Piastre(6) FractionalUnitPluralOtherLang = Piastre(7) FractionalUnitAccusativeOtherLang = Piastre(8) CurrencyISOCode = "EGP" NumberOfDecimalPlaces = 2 isCurrencyFeminine = False CurrencyBaseValue = 0 FractionalUnitBaseValue = 0 GetEgyptianPound = Array(CurrencyNameSingular, _ CurrencyNameDual, _ CurrencyNamePlural, _ CurrencyNameAccusative, _ CurrencyBaseValue, _ FractionalUnitSingular, _ FractionalUnitDual, _ FractionalUnitPlural, _ FractionalUnitAccusative, _ FractionalUnitBaseValue, _ CurrencyNameSingularOtherLang, _ CurrencyNameDualOtherLang, _ CurrencyNamePluralOtherLang, _ CurrencyNameAccusativeOtherLang, _ CurrencyBaseValue, _ FractionalUnitSingularOtherLang, _ FractionalUnitDualOtherLang, _ FractionalUnitPluralOtherLang, _ FractionalUnitAccusativeOtherLang, _ FractionalUnitBaseValue, _ CurrencyISOCode, _ NumberOfDecimalPlaces, _ isCurrencyFeminine) ' Clean up CleanUpVariables End Function فكما تلاحظون على سبيل المثال فى هذه الاسطر FractionalUnitSingular = Piastre(1) FractionalUnitDual = Piastre(2) FractionalUnitPlural = Piastre(3) FractionalUnitAccusative = Piastre(4) ان نوع كسر العملة اذا كان مفردا او مثنى او جمع تم تعريفة من خلال الوظيفة Piastre وبين قويسن الرقم الذى يدل على هذا النوع تبعا للوظيفة التى تم انشائها مسبقا النوع الثانى تم كتابة كل البيانات بدون الاعتماد على اى وظائف او دوال مساعدة اخرى مثل ' Currency Information By Arabic CurrencyNameSingular = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) CurrencyNameDual = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(228) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(199) & Chr(228) CurrencyNamePlural = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(199) & Chr(202) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(201) CurrencyNameAccusative = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(240) & Chr(199) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) & Chr(240) & Chr(199) FractionalUnitSingular = Chr(229) & Chr(225) & Chr(225) & Chr(201) FractionalUnitDual = Chr(229) & Chr(225) & Chr(225) & Chr(202) & Chr(199) & Chr(228) FractionalUnitPlural = Chr(229) & Chr(225) & Chr(225) & Chr(199) & Chr(202) FractionalUnitAccusative = Chr(229) & Chr(225) & Chr(225) & Chr(201) ' Currency Information By Other Language CurrencyNameSingularOtherLang = "Saudi Riyal" CurrencyNameDualOtherLang = "Two Saudi Riyals" CurrencyNamePluralOtherLang = "Saudi Riyals" CurrencyNameAccusativeOtherLang = "One Saudi Riyal" FractionalUnitSingularOtherLang = "Halala" FractionalUnitDualOtherLang = "Two Halalas" FractionalUnitPluralOtherLang = "Halalas" FractionalUnitAccusativeOtherLang = "One Halala" CurrencyISOCode = "SAR" NumberOfDecimalPlaces = 2 isCurrencyFeminine = True CurrencyBaseValue = 1 FractionalUnitBaseValue = 0 ما يهمنا هنا هو النصف الاول وهو اختيار اسم الوظيفة باسم العملات وضع البيانات للعملات فى المتفيرات وهذه المتغيرات هى وكما هو موضح بالجدول الخاص بنوع العملات اسم العملة بصيغة المفرد اسم العملة بصيغة المثنى اسم العملة بصيغة الجمع اسم العملة بصيغة حالة النصب القيمة الأساسية للعملة وهى اما 0 او 1 ويسال عنها خبراء المحاسبة و الحسابات <<---< عارف واحد بيقول انت على الله حكايتك ومصدعنا تفعيل نوع العملة ( مؤنثة ) لاستخدامها في التطبيقات عدد الخانات العشرية المستخدمة في العملة فبعض العملات تتكون اجزائها من ثلاث منازل عشرية وليس اثنان فقط كما هو الشائع اسم كسر العملة بصيغة المفرد اسم كسر العملة بصيغة المثنى اسم كسر العملة بصيغة الجمع اسم كسر العملة بصيغة حالة النصب القيمة الأساسية لكسر العملة ونفس البيانات مرة أخرى للغة الانجليزية ان اردت اللغتان معا او اى لغة اخرى غير الانجليزية جيب الرغبة واخيرا رمز ISO المخصص للعملة : كود العملة او رمز اختصار العملة المتعارف عليه عالميا لا علاقة له بالاكواد نهائيا ولكن وضعتخ لمن يريد اضافته او استخدامه فى تطبيقه تبعا لكل عملة حاسس حد و كمان سامع حد بيقول منا مش فاهم الهيلوغريفى المكتوب ده ويقصد الـ Ascii مثل ( Chr(218) & Chr(230) & Chr(207) ) وهنا تأتى دور الاداة الجبارة و المساعدة فى التحويل الى او من الـ Ascii واحد تانى هناك اهو عمال يقول ايه الصداع ده ووجع النفوخ ده بص يا سيدى انا قلت نبذة عن الاكواد والافكار لمن يريد العلم والتعمق او التعديل عليها اذا اين الزتونة فين من غير وجع راس كتير فهذا ما يشغل الـ End User نسخ الوحدة النمطية ونقلها كما هى الى فاعدة بياناتك للمرة الاول فقط استدعى الوظيفة بالشكل التالى للغة العربية الوضع الافتراضى : ConvertNumberToWords([CurrencyValue]) وطبعا لا تنسيى تغير CurrencyValue باسم الحقل لو يتم الاستدعاء من خلال استعلام او مربع النص لو من نموذج الكود شاطر ذكى وابن حلال من نفسه ينشئ جدول جديد باسم : tblCurrencyInfo ولان انا تعبت بصراحة مكنتش قادر اكمل عملات تانى فى الكود اكثر من تلك الموجودة بالجدول بعد انشائه 9 انواع من العملات تقريبا الان يمكنك اضافة العملات التى تريد التعامل معها فى الجدول بنفس الطريقة يدويا من الحقول مباشرة بعيد عن الاكواد وعلى نفس سيناريو الاسماء المستخدمه لاى عملة المفرد والمثنى والجمع وووو... الخ الان كل ما عليك هو : اختيار نوع عملة واحد فقط من الجدول بتنشيط العملة باستخدام القيمة البولينيه True على ان لا يتم اختيار أكثر من عملة فى آن واحد ستجد ان العملة الافتراضية عند انشاء الجدول هى : ريال سعودي طيب سامعك يا اللى بتقول طب لو عاوز اغير العملة الافتراضية من الكود بحيث تكون هى المؤشر عليها من الكود عند انشاء الجدول للمرة الاولى فقط فى اول الوحدة النمطية تجد الوظيفة الاتية : CurrencyYouWantToBeActive Public Function CurrencyYouWantToBeActive() CurrencyYouWantToBeActive = Chr(209) & Chr(237) & Chr(199) & Chr(225) & Chr(32) & Chr(211) & Chr(218) & Chr(230) & Chr(207) & Chr(237) End Function و تشفير الـ Ascii هذا ترجمته : ريال سعودي اه والله زيمبئولك كده كل كا عليك هو تغيير اسم العملة فى الكود بالاسم المستخدم كبيانات للحقل CurrencyNameSingular طيب لو فتحنا الاستعلام سوف نجد ان التفقيط العربي و الانجليزي مكرر ما السبب السبب فى ذلك هو اولا وبفضل الله تعالى ثم المستشار الامين الاستاذ @Moosak بارك الله فيه عندما كنت اطلب منه التجربة للوقوف على مشاكل الكود البرمجية التى قد تواجه المستخدمين كنت قد اعتمدت فى البداية على ان تكون الارقام من سلسلة نصية بناء عليه الحقل سوف يكون نصى وكان ردة هو الاتى هههههههه اقول له طيب لو مستعجل عدلها انا تعبت خلاص يرد و يقول لى هههههههههههه لذلك تم بفضل الله تعديل الوظيفة فأصبحت وبكل مرونة تتعامل مع كلا النوعين من الحقول النوع النصى والنوع الرقمى والان ايها المستشار المؤتمن جه الوقت لنقول عبى ياا باااااااااااااا إنتهى الموضوع ------------------------------------------------------------------ ان شاء الله تم الانتهاء من التحديث الاخيــــر - تم تحديث الموضوع والمرفقات بتاريخ 18/08/2024 اسباب التحديث : اولا تم زيادة الاعداد التى يقبلها الكود للتعامل مع الرقم الطبيعى مثل 100000000000000000000000000000000000000000000000000000000000000000000000 والرقم العلمى والذى يستخدمه الاكسس فى حقل الارقام لنفس الرقم السابق 1E+71 وتم ضبط الكود فى حالة كان الحقل نصى لكى يتعامل مع الشكلان إما الشكل الطبيعى أو الشكل العلمى ثانيا الكود الان يقوم بعمل تفقيط للعملات او للاعداد بدون عملات وذلك ليكون الكود اكثر مرونه " وده كان رأى الاستاذ موسي " وتم تفقيط الاعداد كما هى تمام سواء بالسالب او الموجب دون الاهذ فى الاعتبار للاصفار على يساء المنار العشرية دى لوحدها اختراع والله وعمرى ما شوفتها اصلا " وده كان رأى الاستاذ موسي " ثالثا الاكواد فى النموذج لتحميل اسماء العملات من جدول العملات الى مربع السرد وهى مجرد استدعاء من دالة فى الوحدة النمطية وذلك اذا اراد المستخدم تفقيط اكثر من عملة مختلفة النوع فى نفس النموذج بسهولة frmBulder رابعا بناء على طلب سيادة المستشار المؤتمن الاستاذ @Moosak تم تصيم نموذج مولد مود الاستدعاء للدوالة بكل أشكال وطرق الاستدعاء المختلفة وفى النهاية يبقى السيناريو الاصلى والاساسى كما كان تماما ولم يتغير أى شئ و يتم الاستدعاء بأشكال متعددة فقط لاضفاء مرونة أكبر كما اشرت فى الاكواد لطرق استدعاء الدالة باشكالها المختلفة فى رأس الموديول وكما هو موضح ايصا فى قاعدة التجربة المرفقة توضيح المرفقات : المرفق الاول : اداة تحويل النصوص من والى الـ Ascii : Text Converter Ascii (v. 3) المرفق الثانى : ملف الوحدة النمطية العامة فقط : basHandleNO2Words المرفق الثالث : قاعدة البيانات الخاصة بالتفقيط :HandleNumber2Words هى قاعدة بيانات تحتوى على موديول اكواد التفقيط للتجربة وتوضيح اشكال الاستدعاء المختلفة Text Converter Ascii (v. 3).accdb basHandleNO2Words.zip HandleNumber2Words V2.0.1- Test.zip

السلام عليكم ورحمة الله تعالى وبركاته اخوانى الكرام اساتذتى الاعزاء الموضوع ده بصراحة كان تحدى بينى وبين نفسي تعبت جدا فكرة الموضوع التقليدية هى التعامل بالارقام واسماء العناصر وكتابة الكثير والكثير من الاكواد والزحمة والحسابات و و وبلا بلا بلا بلا... وفى النهاية يبقى التعديل على العمل بالاضافة او التعديل شئ صعب جدا جدا جدا الا انه بفضل الله اقدم اليكم الفكرة الاتية للتجربة اعتمدت فى المقام الاول على ان تكون الاكواد ثابته بحيث يسهل استخدام الفكرة والطريقة ونقلها لاى قاعدة ولكن عجزت عن تحقيق كل شئ برمجيا وتوقفت وعجزت امام نقطة واحدة ووحيدة ولكن تم التغلب بالفهلوة على المشكلة اترك لكم التجربة وباب النقاش مفتوح بعد ذلك ومن يدرى فد اجد حل للمشكلة التى عجزت امامها معكم وعندكم تعديل جديد بتاريخ 31/05/2024 تم تحديث الموضوع باضافة الاصدار الثانى الذى يعتمد كليا على الوحدات النمطية تم حل جميع المشاكل والعقبات برمجيا والتى واجهتنى بالاصدار الاول على الرغم من انه قد تم التغلب عليها وقتها ولكن بحلول غير برمجية الإصدار الأول : expand and collapse button .accdb الإصدار الثاني (المحسن) : expand and collapse button V2.zip

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

اولا شكرا على الهدية ثانيا اسمح لي بإضافة الملف في الموضوع بعد الضغط والاصلاح للملف من خلال الاكسس ... لان ملف الميديا يمكن حذفه بعد فترة من الزمن وسوف يخسر المنتدى هذه الهدية القيمة ..... Ferry Login v1free.accdb

هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm

جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm

بعد توجيهات أستاذنا @ابوخليل تفضل استاذ @zero1111330566 محاولتي حسب مافهمت اليك الشرح والمرفق . ووافني بالرد . الاصناف_1.rar