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

[dd13901390]

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

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

حساب التاريخ.accdbFetching info...

[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.accdbFetching info...

[kkhalifa1960]

مشاركة مع استاذ @Foksh تفضل استاذ @dd13901390 محاولتي اليك نموذجان الول يعمل على الجدول مباشرتاً  والثاني بواسطة استعلام اختار مايناسبك . 

حساب التاريخ.accdbFetching info...

[dd13901390]

اشكر جميع الاخوان 

[dd13901390]

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

 

تفقيط التاريخ 1.accdbFetching info...

تم تعديل الإثنين at 19:16 بواسطه dd13901390
تعديل على المطلوب

[Foksh]

  في 7‏/4‏/2025 at 19:12, dd13901390 said:

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

 

تفقيط التاريخ 1.accdb 780 kB · 3 downloads

Expand  

العفو يا صديقي ، ولا يهمك ,,

لك مني نصيحة وهي الابتعاد عن التسميات العربية للحقول أو الجداول أو النماذج أو مكوناتها .. لذا قمت بتغيير اسم مربع النص الخاص بالحالة = 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.accdbFetching info...

 

[dd13901390]

اخي foksh شكرا جزيلا على المساعدة

 

•  

 

[dd13901390]

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

تفقيط التاريخ 1 (2).accdbFetching info...

[Foksh]

معلش استحملني شوية ، ما فهمتش ازاي الفرق بين 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

 

تم تعديل الثلاثاء at 10:39 بواسطه Foksh
تقديم مقترح

[dd13901390]

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

تم تعديل الثلاثاء at 16:56 بواسطه dd13901390

[Foksh]

  في 8‏/4‏/2025 at 16:48, dd13901390 said:

هلا اخوي لا ابغى سنة او اكثر يكون اخضر اقل من سنة يكون احمر ولك الشكر

Expand  

اعتذر عن المتابعة ..  

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

تم تعديل الثلاثاء at 16:55 بواسطه Foksh

[dd13901390]

اسف جدا اخوي foksh  ولكن ارجو من الله ثم منك اخوي المساعدة وانني محتاج لهذا الشرح اريد عندما يكون الصلاحية سنة يحسب من تاريخ الجهاز مثلا اخوي تاريخ اليوم 2025/04/08

1- عندما ادخل تاريخ البداية 2024/04/08 حتى 2025/04/08 هذة المدة طبعا سنة يكون اخضر او 2024/04/08 حتى 2026/04/08 سنتان اخضر 

2- عندما ادخل تاريخ البداية 2024/04/07 حتى تاريخ امس2025/04/07 يكون احمر لان تاريخ اليوم في الجهاز 2025/04/08  هذا المطلوب والرجاء المساعدة 

 

اسف جدا على الاطالة

[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

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).accdbFetching info...

[dd13901390]

جزاك الله خير الجزاء اخوي Foksh