دالة تفقيط التاريخ لابن خليفه الجموعي

[ناصر سعيد]

السلام عليكم ورحمة الله تعالى وبركاته
أقدم لكم دالة تفقيط التاريخ
لن أطيل عليكم الدالة في المرفق
لا تنسونا من خالص دعائكم

 

Function DateToLettre(Dat As Date) As String
' Created By Benkhalifa
' Djemoui Alger: 23/02/2018
Dim MyDays As Variant
Dim MyMonths As Variant
Dim MyChif As Variant
Dim Cent As String
Dim Mill As String
Dim i, J As Byte: J = 0
'===============================================================================================================================
MyDays = Array("اليوم الأول", "اليوم الثاني", "اليوم الثالث", _
"اليوم الرابع", "اليوم الخامس", "اليوم السادس", _
"اليوم السابع", "اليوم الثامن", "اليوم التاسع", _
"اليوم العاشر", "اليوم الحادي عشر", "اليوم الثاني عشر", _
"ليوم الثالث عشر", "اليوم الرابع عشر", "اليوم الخامس عشر", _
"اليوم السادس عشر", "اليوم السابع عشر", "اليوم الثامن عشر", _
"اليوم التاسع عشر", "اليوم العشرون", "اليوم الواحد و العشرون", _
"اليوم الثاني و العشرون", "اليوم الثالث و العشرون", "اليوم الرابع و العشرون", _
"ليوم الخامس و العشرون", "اليوم السادس و العشرون", "اليوم السابع و العشرون", _
"اليوم الثامن و العشرون", "اليوم التاسع و العشرون", "اليوم الثلاثون", _
"اليوم الواحد و الثلاثون")
'===============================================================================================================================
MyMonths = Array("شهر يناير", "شهر فبراير", "شهر مارس", _
"شهر أبريل", "شهر مايو", "شهر يونيو", _
"شهر يوليو", "شهر اغسطس", "شهر سبتمبر", _
"شهر أكتوبر", "شهر نوفمبر", "شهر ديسمبر")
'===============================================================================================================================
MyChif = Array("صفر", "واحد", "إثنان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع", _
"عشرة", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", _
"تسعة عشر", "عشرون", "واحد و عشرون", "إثنان و عشرون", "ثلاثة و عشرون", "أربعة و عشرون", "خمسة و عشرون", "ستة و عشرون", _
"سبعة و عشرون", "ثمانية و عشرون", "تسعة عشرون", "ثلاثون", "واحد و ثلاثون", "إثنان و ثلاثون", "ثلاثة و ثلاثون", "أربعة و ثلاثون", _
"خمسة و ثلاثون", "ستة و ثلاثون", "سبعة و ثلاثون", "ثمانية و ثلاثون", "تسعة و ثلاثون", "أربعون", _
"واحد و أربعون", "إثنان و أربعون", "ثلاثة و أربعون", "أربعة و أربعون", "خمسة و أربعون", "ستة و أربعون", _
"سبعة و أربعون", "ثمانية و أربعون", "تسعة و أربعون", "خمسون", "واحد و خمسون", "إثنان و خمسون", "ثلاثة و خمسون", "أربعة و خمسون", _
"خمسة و خمسون", "ستة و خمسون", "سبعة و خمسون", "ثمانية و خمسون", "تسعة و خمسون", "ستون", "واحد و ستون", _
"إثنان و ستون", "ثلاثة و ستون", "أربعة و ستون", "خمسة و ستون", "ستة ستون", _
"سبعة و ستون", "ثمانية و ستون", "تسعة و ستون", "سبعون", "واحد و سبعون", "إثنان و سبعون", "ثلاثة و سبعون", _
"أربع و سبعون", "خمس و سبعون", "ستة و سبعون", "سبعة و سبعون", "ثمانية و سبعون", "تسعة و سبعون", "ثمانون", "واحد و ثمانون", _
"إثنان و ثمانون", "ثلاث و ثمانون", "أربعة و ثمانون", "خمسة و ثمانون", "ستة و ثمانون", "سبعة و ثمانون", _
"ثمانية و ثمانون", "تسع و ثمانون", "تسعون", "واحد و تسعون", "إثنان و تسعون", "ثلاثة و تسعون", "أربعة و تسعون", _
"خمسة و تسعون", "تسعون", "سبعة و تسعون", "ثمانية و تسعون", "تسعة و تسعون", " مائة ")
'===============================================================================================================================
Do While J < 2
i = Mid$(Year(Dat), J + 1, 4)
'===============================================================================================================================
If Len(i) = 4 Then
    Select Case i
        Case 1 To 999: Mill = MyChif(i)
        Case 1000 To 9999:
            Select Case Int(i / 1000)
                Case 1: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = " ألف" Else: Mill = " ألف و "
                Case 2: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = " ألفان" Else Mill = " ألفان و "
                Case 3 To 10: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = MyChif(Int(i / 1000)) & " آلاف" Else If Int(i / 1000) = 8 Then Mill = MyChif(Int(i / 1000)) & "ية آلاف و " Else Mill = MyChif(Int(i / 1000)) & "ة آلاف و "
            End Select
    End Select
End If
'===============================================================================================================================
If Len(i) = 3 Then
    Select Case i
        Case 1 To 100: Cent = MyChif(i)
        Case 101 To 199: Cent = " مائة و " & MyChif(i Mod 100)
        Case 201 To 299: Cent = " مائتان و " & MyChif(i Mod 100)
        Case 300 To 999:
            Select Case (i Mod 100)
                Case 0: If Format(Mid$(i, 2, 4), "00") = "00" Then Cent = MyChif(Int(i / 100)) & " مائة " Else Cent = MyChif(Int(i / 100)) & " مائة و "
                Case 1 To 99: Cent = MyChif(Int(i / 100)) & "مائة و " & MyChif(i Mod 100)
            End Select
    End Select
End If
'===============================================================================================================================
J = J + 1
Loop
'===============================================================================================================================
DateToLettre = MyDays(Day(Dat) - 1) & " من " & MyMonths(Month(Dat) - 1) & " عام " & Mill & Cent
End Function

منقول لنشر العلم

جزى الله .. المحترم الخلوق بن خليفه الجموعي

بكل خير

دالة تفقيط التاريخ.rar

[Ali Mohamed Ali]

وعليكم السلام -بارك الله فيك أخى ناصر وحفظك من كل سوء انت وأستاذنا ابن الجموعى

كود فى غاية الإبداع -دائما تعلمنا وتبهرنا إلى التقدم

[أ / محمد صالح]

بارك الله لكم

دالة رائعة تقوم بالتفقيط حتى عام 9999

ذكرتني بهذه الدالة كنت قد صممتها في 2008

هنـــــــا

لنفس الغرض ولكن بالأكسس

وللعلم تم تطوير هذه الدالة بصورة أكثر احترافية

ربما أعرضها في موضوع جديد في منتدى الأكسس إن شاء الله

[ناصر سعيد]

Function DateToLettre(Dat As Date, Criteria As Byte) As String
' Created By Benkhalifa
' Djemoui Alger: 23/02/2018
Dim MyDays As Variant
Dim MyMonths As Variant
Dim MyChif As Variant
Dim Cent As String
Dim Mill As String
Dim i, J As Byte: J = 0
'===============================================================================================================================
MyDays = Array("", "اليوم الأول", "اليوم الثاني", "اليوم الثالث", "اليوم الرابع", "اليوم الخامس", "اليوم السادس", _
"اليوم السابع", "اليوم الثامن", "اليوم التاسع", "اليوم العاشر", "اليوم الحادي عشر", "اليوم الثاني عشر", _
"ليوم الثالث عشر", "اليوم الرابع عشر", "اليوم الخامس عشر", "اليوم السادس عشر", "اليوم السابع عشر", "اليوم الثامن عشر", _
"اليوم التاسع عشر", "اليوم العشرون", "اليوم الواحد و العشرون", "اليوم الثاني و العشرون", "اليوم الثالث و العشرون", "اليوم الرابع و العشرون", _
"ليوم الخامس و العشرون", "اليوم السادس و العشرون", "اليوم السابع و العشرون", "اليوم الثامن و العشرون", "اليوم التاسع و العشرون", "اليوم الثلاثون", _
"اليوم الواحد و الثلاثون")
'===============================================================================================================================
MyMonths1 = Array("", "شهر جانفي", "شهر فيفري", "شهر مارس", "شهر أفريل", "شهر ماي", "شهر جوان", "شهر جويلية", "شهر أوت", "شهر سبتمبر", "شهر أكتوبر", "شهر نوفمبر", "شهر ديسمبر")
MyMonths2 = Array("", "شهر يناير", "شهر فبراير", "شهر مارس", "شهر أبريل", "شهر مايو", "شهر يونيو", "شهر يوليو", "شهر أغسطس", "شهر سبتمبر", "شهر أكتوبر", "شهر نوفمبر", "شهر ديسمبر")
MyMonths3 = Array("", "شهر كانون الثاني", "شهر شباط", "شهر آذار", "شهر نيسان", "شهر أيار", "شهر حزيران", "شهر تموز", "شهر آب", "شهر أيلول", "شهر تشرين الأول", "شهر تشرين الثاني", "شهر كانون الأول")
MyMonths4 = Array("", "شهر محرم", "شهر صفر", "شهر رييع الأول", "شهر ربيع الثاني", "شهر جمادى الأول", "شهر جمادى الثاني", "شهر رجب", "شهر شعبان", "شهر رمضان", "شهر شوال", "شهر ذي القعدة", "شهر ذي الحجة")
'===============================================================================================================================
MyChif = Array("صفر", "واحد", "إثنان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع", _
"عشرة", "إحدى عشر", "إثنى عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", _
"تسعة عشر", "عشرون", "واحد و عشرون", "إثنان و عشرون", "ثلاثة و عشرون", "أربعة و عشرون", "خمسة و عشرون", "ستة و عشرون", _
"سبعة و عشرون", "ثمانية و عشرون", "تسعة عشرون", "ثلاثون", "واحد و ثلاثون", "إثنان و ثلاثون", "ثلاثة و ثلاثون", "أربعة و ثلاثون", _
"خمسة و ثلاثون", "ستة و ثلاثون", "سبعة و ثلاثون", "ثمانية و ثلاثون", "تسعة و ثلاثون", "أربعون", _
"واحد و أربعون", "إثنان و أربعون", "ثلاثة و أربعون", "أربعة و أربعون", "خمسة و أربعون", "ستة و أربعون", _
"سبعة و أربعون", "ثمانية و أربعون", "تسعة و أربعون", "خمسون", "واحد و خمسون", "إثنان و خمسون", "ثلاثة و خمسون", "أربعة و خمسون", _
"خمسة و خمسون", "ستة و خمسون", "سبعة و خمسون", "ثمانية و خمسون", "تسعة و خمسون", "ستون", "واحد و ستون", _
"إثنان و ستون", "ثلاثة و ستون", "أربعة و ستون", "خمسة و ستون", "ستة ستون", _
"سبعة و ستون", "ثمانية و ستون", "تسعة و ستون", "سبعون", "واحد و سبعون", "إثنان و سبعون", "ثلاثة و سبعون", _
"أربع و سبعون", "خمس و سبعون", "ستة و سبعون", "سبعة و سبعون", "ثمانية و سبعون", "تسعة و سبعون", "ثمانون", "واحد و ثمانون", _
"إثنان و ثمانون", "ثلاث و ثمانون", "أربعة و ثمانون", "خمسة و ثمانون", "ستة و ثمانون", "سبعة و ثمانون", _
"ثمانية و ثمانون", "تسع و ثمانون", "تسعون", "واحد و تسعون", "إثنان و تسعون", "ثلاثة و تسعون", "أربعة و تسعون", _
"خمسة و تسعون", "تسعون", "سبعة و تسعون", "ثمانية و تسعون", "تسعة و تسعون", " مائة ")
'===============================================================================================================================
Do While J < 2
i = Mid$(Year(Dat), J + 1, 4)
'===============================================================================================================================
If Len(i) = 4 Then
    Select Case i
        Case 1 To 999: Mill = MyChif(i)
        Case 1000 To 9999:
            Select Case Int(i / 1000)
                Case 1: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = " ألف" Else: Mill = " ألف و "
                Case 2: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = " ألفان" Else Mill = " ألفان و "
                Case 3 To 10: If Format(Mid$(i, 2, 4), "000") = "000" Then Mill = MyChif(Int(i / 1000)) & " آلاف" Else If Int(i / 1000) = 8 Then Mill = MyChif(Int(i / 1000)) & "ية آلاف و " Else Mill = MyChif(Int(i / 1000)) & "ة آلاف و "
            End Select
    End Select
End If
'===============================================================================================================================
If Len(i) = 3 Then
    Select Case i
        Case 1 To 100: Cent = MyChif(i)
        Case 101 To 199: Cent = " مائة و " & MyChif(i Mod 100)
        Case 201 To 299: Cent = " مائتان و " & MyChif(i Mod 100)
        Case 300 To 999:
            Select Case (i Mod 100)
                Case 0: If Format(Mid$(i, 2, 4), "00") = "00" Then Cent = MyChif(Int(i / 100)) & " مائة " Else Cent = MyChif(Int(i / 100)) & " مائة و "
                Case 1 To 99: Cent = MyChif(Int(i / 100)) & "مائة و " & MyChif(i Mod 100)
            End Select
    End Select
End If
'===============================================================================================================================
J = J + 1
Loop
'===============================================================================================================================
Select Case Criteria
Case 1: DateToLettre = MyDays(Day(Dat)) & " من " & MyMonths1(Month(Dat)) & "  لعام " & Mill & Cent & " ميلادية"
Case 2: DateToLettre = MyDays(Day(Dat)) & " من " & MyMonths2(Month(Dat)) & "  لعام " & Mill & Cent & " ميلادية"
Case 3: DateToLettre = MyDays(Day(Dat)) & " من " & MyMonths3(Month(Dat)) & "  لعام " & Mill & Cent & " ميلادية"
Case 4: DateToLettre = MyDays(Day(Dat)) & " من " & MyMonths4(Month(Dat)) & "  لعام " & Mill & Cent & " هجرية"
End Select
End Function

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

[ناصر سعيد]

في 2/25/2018 at 01:55, ali mohamed ali said:

وعليكم السلام -بارك الله فيك أخى ناصر وحفظك من كل سوء انت وأستاذنا ابن الجموعى

كود فى غاية الإبداع -دائما تعلمنا وتبهرنا إلى التقدم

وبارك الله  فيك اخي استاذ علي ورعاك

[Ali Mohamed Ali]

بعد اذنك أستاذ ناصر أنا مش عارف ليه مش عايز يظبط معايا ويقوم بتفقيط التاريخ الهجرى تمام

ممكن تضبطه أستاذنا الغالى

دالة تفقيط التاريخ سواء -ميلادى-هجرى.rar

تم تعديل فبراير 26, 2018 بواسطه ali mohamed ali

[ناصر سعيد]

تفضل اخي الكريم

 

دالة تفقيط التاريخ حسب تسميات الشهور في بعض المناطق العربية.rar

[Ali Mohamed Ali]

بارك الله فيك ووفقك أحسنت وابدعت

دائما تبهرنا أستاذى الكريم

[MMElmasry]

الف الف شكر وتسلم على مجهودك

 

[brahimba2]

شكرا أستاذ على مجهوداتك

.هل ممكن دالة تفقيط تاريخ ؟