تفقيط التاريخ ⭐ هدية ~ تفقيط و تحويل الفترات الزمنية إلى نص⭐

[Foksh]

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء )

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

💥 الفكرة العامة للدالة

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

 

تم تعديل April 8 بواسطه Foksh
تحديث وتعديل

[ابوخليل]

فكرة جديدة غريبة والعمل مرتب ورائع ..

اثابك الله على جهدك وتعبك .. وأحسن اليك

[Moosak]

5 ساعات مضت, Foksh said:

يتم التحقق من أن التاريخ الأول (StartDate) لا يأتي بعد التاريخ الثاني (EndDate) ، وإذا كان الأمر كذلك ، يتم إخراج رسالة خطأ .

عمل إبداعي متميز .. من شخص ليس بغريب عليه الإبداع 🙂 

فكرة رائعة ومتعددة الخيارات بكل ما يخطر على بال المستخدم .. ماشاء الله 
 

عندي مقترحين وهما لايغيران من جمال وروعة العمل : 😁🖐️

1- بالنسبة لو تم إدخال تاريخ نهاية أصغر من تاريخ البداية .. أقترح أن يتم تبديلهما تلقائيا بدون رسائل خطأ ( يقدم التاريخ الأصغر كتاريخ بداية والأكبر كتاريخ نهاية ) <------ مجرد رأي 😎

2- حبذا لو تضيف خدمة تفقيط التواريخ (وليس الفرق بين تاريخين) ...

    مثال : 08/04/2024 ------(يصبح)--------> الثامن من شهر إبريل للعام ألفين وأربعة وعشرين للميلاد .. <------ مجرد إقتراح 

 

والباقي ما عليه كلام يا سيد المبدعين 

[moho58]

عمل رائع جدا

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

[Foksh]

7 ساعات مضت, ابوخليل said:

فكرة جديدة غريبة والعمل مرتب ورائع ..

اثابك الله على جهدك وتعبك .. وأحسن اليك

وإياكم معلمنا الجليل ، وبارك الله بكم وبصحتكم وعافيتكم ومالكم وأهلكم أجمعين ..

نحاول السير على خطاكم ليس إلا 😊 .

 

3 ساعات مضت, Moosak said:

عمل إبداعي متميز .. من شخص ليس بغريب عليه الإبداع 🙂 

فكرة رائعة ومتعددة الخيارات بكل ما يخطر على بال المستخدم .. ماشاء الله 
 

عندي مقترحين وهما لايغيران من جمال وروعة العمل : 😁🖐️

1- بالنسبة لو تم إدخال تاريخ نهاية أصغر من تاريخ البداية .. أقترح أن يتم تبديلهما تلقائيا بدون رسائل خطأ ( يقدم التاريخ الأصغر كتاريخ بداية والأكبر كتاريخ نهاية ) <------ مجرد رأي 😎

2- حبذا لو تضيف خدمة تفقيط التواريخ (وليس الفرق بين تاريخين) ...

    مثال : 08/04/2024 ------(يصبح)--------> الثامن من شهر إبريل للعام ألفين وأربعة وعشرين للميلاد .. <------ مجرد إقتراح 

 

والباقي ما عليه كلام يا سيد المبدعين 

أهلا مهندسنا الغالي .. أشكر ثقتكم ودمعكم المتواصل .. وليس لي غنى عن مقترحاتكم وانتقاداتكم ,

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

 

2 ساعات مضت, moho58 said:

عمل رائع جدا

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

جزاكم الله خيراً أخي العزيز .. وبارك الله بكم ، شرفتموني بتعليقكم 😇 .

[Foksh]

تم تعديل April 8 بواسطه Foksh

[Mostafa Wasfi]

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

[Foksh]

منذ ساعه, Mostafa Wasfi said:

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

وبارك الله بكم أخي الكريم ،،

هو متاح للجميع دون استئذان ، وصدقة جارية عن روح والدي رحمه الله ,,

فدعائكم له بالرحمة أكبر مكافأة  .