حساب الفرق بين تاريخين والنتيجة حروف

[dd13901390]

بعد التحية الطيبة للاخوان الرجاء المساعدة في هذا المثال 

المطلوب حساب الفرق بين تاريخين واظهار النتيجة في المدة فقط حروف لا اريد ارقام مثلا سنة او سنتان وهكذا 

حساب التاريخ.accdb

[Foksh]

وعليكم السلام ورحمة الله وبركاته ..

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

[Foksh]

اعتذر عن التأخير ..

في مديول جديد ، الصق الكود التالي :-

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