Foksh

طيب استحملوني في استفساراتي حتى نعلم كيف يمكننا حصر المشكلة والخروج بحل مناسب . كيف سيتم حصر عدد ايام الحضور في العام الدراسي ؟؟ لذا افكر في جدول مخصص لإعدادات هذه المشكلة ، بحيث يضم الحقول التالية على سبيل المثال :- حقل العام الدراسي = 2024 / 2025 م على سبيل المثال وكما هو متبع في تأسيسكم . حقل عدد أيام الحضور الكلي . ويتم تحديدها من طرف الإدارة أو المسؤول . حقل النسبة المئوية المطلوبة = لجعل الفكرة أكثر مرونة عند التطبيق . 4 حقول تمثل ( تاريخ بداية ونهاية الفصل الأول والثاني ) منفصلة . حالة العام الدراسي = حقل اختياري من نوع Yes/No ما رأيكم ؟

رأيي في معلمي .. سامحك الله أستاذي الفاضل .. العين لا تعلو عن الحاجب ، بل أضف إليها ( لا و لن ) على العموم بتصوري لشكل النتيجة سيكون كالتالي :- انا كتبت هذا التعليق وظننت أني قد ارفقته ، على العموم سأحاول المشاركة في إبداء رأيي المتواضع والبحث عن فكرة أخرى مساندة ونشكركم لثقتكم

لي مداخلة ايضاً حاولت تتبعها لكني الصحيح دخلت في دوامة .. في الجدول Tbl_student حيث رقم الطالب الفريد = id_student صحيح ؟؟ بينما في الجدول Tbl_degree_Detail حيث معرف الطالب = Stu_card !!!! ولدي ايضاً سؤال آخر ( مؤجل في الوقت الحالي ) حتى أفهم أكثر آلية العمل التي تم تأسيسها في المشروع على العموم ، هل الصورة التالية تعكس النتيجة المطلوبة كقيم لمادة الحضور ؟؟ أم أنني ابتعدت عن محور الحديث والمطلوب 😅😅 ؟؟ لم أطلع على المرفق من طرف أستاذي ابو خليل لعدم تحديثي للصفحة

أخي الكريم @The best ، فقط للتذكير . ذكرني بأسماء الجداول التي تتعلق بمعلومات العميل الرئيسية .. شوف الصورة دي من الجدول الخاص بمعلومات العميل .. ولا في معلومات وبيانات تانية خاصة بجداول تانية هتملاها من نفس النموذج ؟؟؟

الى حد ما توضحت الفكرة .. ولكن لي تعليق على ما تفضلت به سابقاً !!! هذه الجملة " فى حالة total =صفر واسم المعمل فارغ اريد اسم المريض واسم المعمل بدون تنسيق " عكس هذا الطلب كلياً .. " عندما يكون اسم المعمل فارغ Total_out اكبر من صفر يصبح اللون الخلفية ازرق فى اسم المعمل واسم المريض " هل ما تقصده total = Total_out هو نفسه ؟؟؟؟؟ على العموم هل الفكرة التالية صحيحة :-

المطلوب غير واضح أخي الكريم

ليس من طبعي عدم استكمال بداية قد بدأتها ،ولكنك اخي الكريم في كل مرة تقوم بتوجيه طلب مختلف ، أو انك من البداية لم تقم بتوضيح المطلوب بشكل جيد . وها ما جعلني استنكف عن المتابعة . لكن على العموم ، اتمنى ان لايكون الهدف في رأسك غير الذي أشرت اليه مؤخراً . ولذا فهذه تجربتي علها تكون ما تريده . المديول سيصبح بهذا الشكل ( التعديل فقط على الدالة الأخيرة ) .. Function DurationToWords(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then DurationToWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If Select Case diff Case Is < 0 DurationToWords = "تاريخ غير صالح" Case 0 DurationToWords = "أقل من سنة" Case 1 DurationToWords = "سنة واحدة" Case 2 DurationToWords = "سنتان" Case 3 To 10 DurationToWords = NumberToArabicWords(diff, True) & " سنوات" Case Else DurationToWords = NumberToArabicWords(diff, True) & " سنة" End Select 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 GetDurationStatus(StartDate As Variant, EndDate As Variant) As String If IsNull(StartDate) Or IsNull(EndDate) Then GetDurationStatus = "" Exit Function End If If EndDate < Date Then GetDurationStatus = "Expired" Else GetDurationStatus = "Current" End If End Function وفي التنسيق الشرطي استدعينا الدالة بها الشكل كما في الصورة :- حيث تم استدعاء الدالة مع تحديد اذا كانت النتيجة = Expired أو Current لتحديد اللون . المرفق الأخير :- تفقيط التاريخ 1 (2).accdb

بدايةً اعتذر عن عدم الرد سابقاً ، وان شاء الله إن استطعت الليلة سأقوم باقتراح نموذج يلبي الاحتياجات.

طيب استحملني في كم سؤال كده .. بما اني ما حملتش الملف في الوقت الحالي ، هل لديك جدول خاص بالحضور ؟؟؟؟ وكيف يتم ربط جدول الدرجات بجدول الحضور (مفتاح الربط) اذا كان موجود ؟؟

اعتذر عن المتابعة .. فأنت لا تعرف ماذا تريد 🙄

أخي الكريم @2saad ، قرابة اليوم ولم تجد اي إجابة .. صحيح ؟؟ يبدو انك لم تقم بالتوضيح المطلوب والشرح الوافي كي تساعد من يمر من هنا على فهم المعطيات بشكل جيد . فالأستاذ @ابوخليل جزاه الله خيراً كان معك من بداية الطريق عندما بدأتم تصميم الفكرة ، وهو على دراية بمخرجات ومدخلات سير العمل على مشروعك . لذا نرجو منك زيادة الشرح بإسهاب كي تتوضح لنا فكرة العمل التي نريد التعديل عليها , وجزاكم الله كل خير

وإياكم معلمنا الجليل ، وبارك الله بكم وبصحتكم وعافيتكم ومالكم وأهلكم أجمعين .. نحاول السير على خطاكم ليس إلا 😊 . أهلا مهندسنا الغالي .. أشكر ثقتكم ودمعكم المتواصل .. وليس لي غنى عن مقترحاتكم وانتقاداتكم , وان شاء الله سأحاول إضافة الأفكار التي طرحتموها علها تكون ذات فائدة أكبر من خلال هذا العمل المتواضع . جزاكم الله خيراً أخي العزيز .. وبارك الله بكم ، شرفتموني بتعليقكم 😇 .

معلش استحملني شوية ، ما فهمتش ازاي الفرق بين 01/01/2024 و 01/01/2025 يكون أقل من سنة ؟؟؟؟؟؟ ولا انت عايز ايه بالضبط ما فهمتش من المثال اخي الكريم . يعني انت عايزها لو سنة يكون منتهي الصلاحية وباللون الأحمر ؟؟؟؟ ولو أكتر من سنة يكون أخضر ؟؟؟؟ أتمنى أن لا يكون جوابك نعم !!!!! لأن حضرتك عايز تقارن بين التاريخين على مستوى السنة ,, يعني :- 01/01/2023 و 01/01/2025 = سنتين وسيكون الناتج اخضر والصلاحية فعالة 02/01/2023 و 01/01/2025 = ستكون النتيجة سنة واحدة وبالتالي سيكون اللون أحمر ومنتهي الصلاحية . اذا كانت ملتزماً بفترات = سنة واحدة فلك ذلك بإضافة شرط للشرط التنسيقي كما في الصورة :- وتعديل الدالة الأخيرة في المديول الى التالي :- Function GetDurationStatus(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then GetDurationStatus = "" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) - 1 '<----------- تم التعديل هنا بطرح يوم واحد فقط If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If If diff < 1 Then GetDurationStatus = "Expired" Else GetDurationStatus = "Current" End If End Function

وعليكم السلام ورحمة الله وبركاته .. التنسيقات والمسافات خطوة يتبعها مبرمجوا وكاتبوا الأكواد لتتبع بداية ونهاية الأجزاء ، وخصوصاً الجمل والدوال والأكواد التي لها بداية ونهاية مثل الجمل الشرطية If أو Select .... الخ لذا فهي ليست ذات أي تأثير على سرعة أداء الكود أو عدم فعاليته . وجهة نظري البسيطة ، والله تعالى أعلم

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي 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

فيما يخص هذا الجزء، حتى الآن أمورك تمام ، ولكن فيما بعد ان إضطررنا للتعديل فالأمر بسيط ويسير ان شاء الله . هنا سأقدم لك نصيحة من واقع التصميم ، وهي حاول السير على خطوات تصميم واحد يتوافق ويتجانس مع باقي النماذج . فمثلاً زر التراجع هل يعمل ؟؟ ما فائدة النموذج الفرعي الذي يتم فيه عرض الجنسيات على سبيل المثال ؟ ما تبقى فأنت صاحب المشروع ولك نظرتك وحاجتك وليس لنا إلى ابداء الرأي وعليك الإختيار .

أخي الكريم ، عمر آخر مشاركة تقريباً 7 سنوات ، لذا أنصحك بفتح موضوع جديد مستقل وشرح طلبك بالتفصيل ، وبإذن الله ستحصل على جواب من الأخوة والأساتذة الكرام ,,

العفو يا صديقي ، ولا يهمك ,, لك مني نصيحة وهي الابتعاد عن التسميات العربية للحقول أو الجداول أو النماذج أو مكوناتها .. لذا قمت بتغيير اسم مربع النص الخاص بالحالة = Tx_Status . وعليه فقد استخدمت التنسيق الشرطي لتنفيذ طلبك مع دالة جديدة لإضافة كلمة Expired أو Current ,, حيث الدالة الجديدة :- Function GetDurationStatus(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then GetDurationStatus = "" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If If diff < 1 Then GetDurationStatus = "Expired" Else GetDurationStatus = "Current" End If End Function صورة توضيحية :- الملف المرفق :- تفقيط التاريخ 1.accdb

اعتذر عن التأخير .. في مديول جديد ، الصق الكود التالي :- Function DurationToWords(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then DurationToWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If Select Case diff Case Is < 0 DurationToWords = "تاريخ غير صالح" Case 0 DurationToWords = "أقل من سنة" Case 1 DurationToWords = "سنة واحدة" Case 2 DurationToWords = "سنتان" Case 3 To 10 DurationToWords = NumberToArabicWords(diff, True) & " سنوات" Case Else DurationToWords = NumberToArabicWords(diff, True) & " سنة" End Select 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 وفي حدث بعد التحديث لمربعي نص التاريخ :- Private Sub date2_AfterUpdate() Me.mo = DurationToWords([date1], [date2]) End Sub Private Sub date1_AfterUpdate() Me.mo = DurationToWords([date1], [date2]) End Sub تفقيط التاريخ 1.accdb

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

العفو اخي الكريم 😇 بعد 4 أسابيع ارجو منك اغلاق الموضوع باختيار أفضل إجابة.

وعليكم السلام ورحمة الله وبركاته اخي الفاضل لأن Date هي دالة مضمنة لا تتطلب أقواس إذا لم تكن تُستدعى كجزء من تعبير داخل دالة أخرى . وهذا طبيعي وسليم وصحيح 100% وعادة لا يتم حذف القوسين عند استدعاء دالة عامة باسمها الصريح باستخدام call هذا رأيي والله أعلم

نعم اخي الكريم ، في العام الجديد سيبدأ الترقيم من جديد

أشكرك أخي @kkhalifa1960 على الإلتفاتة الجميلة ، ولكن اسمح لي بمداخلة متفرعة . اذا كان طلب الأخ @حافظ التونسي هو وجود 0000 بعد رقم السنة ثم يبدأ الترقيم دون التأثير على الـ 0000 بحيث النتيجة تكون بهذا الشكل :- 202500001 ، 202500002 ، .... 2025000010 ، 2025000011 .... 2025000099999 = فإن اقتراحك جميل ويلبي الغرض . أما اذا كانت الفكرة كما تم تحديدها "رقم التسلسلي يتكون من رقم يحتوي على السنة الحالية و معها 5 ارقام ك 202500001" بحيث تكون بهذا الشكل :- 202500001 ، 202500002 ، 202500003 ، .... 202500010 ، 202500011 .... إلخ .... 202599999 = فأن التعديل الصحيح من جهتي سيكون للسطر الأخير بالشكل التالي :- GenerateID = CLng(yearPrefix & Format(serialPart + 1, "00000")) هنا سأضمن لك أن يكون الترقيم مكوناً من 5 خانات ، بوساطة دالة Format .. ويقبل التعديل حسب عدد الخانات التي يريدها صاحب الطلب بتغيير عدد الأصفار فقط . إلا أنني تجاهلت التقيد بعدد خانات محددة مثل ( 00000 ) . فنهاية الترقيم ستكون 202599999 . ولكن ماذا لو كان هناك سجل جديد وما زال العام 2025 لم ينتهي !؟!؟ لذا لم أقم بإضافتها أو التقيد بها أخي العزيز خليفة .