كيفية كتابة تاريخ بالحروف

عبد الغني1 · ديسمبر 14, 2012

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

كيفية كتابة تاريخ بالحروف.rar

**الـعيدروس** · ديسمبر 14, 2012

كتابة التاريخ بالحروف

جانفي فيفري

في أي لغة فرنسية ام ماذا ؟

عبد الغني1 · ديسمبر 14, 2012

أخي العزيز تسمية الشهور بالفرنسية

ياسر خليل أبو البراء · ديسمبر 14, 2012

بارك الله فيك أخي الحبيب

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

Function DateToWords(ByVal DateIn As Variant) As String

  Dim Yrs As String, Hundreds As String, Decades As String

  Dim Tens As Variant, Ordinal As Variant, Cardinal As Variant

  Ordinal = Array("First", "Second", "Third", "Fourth", "Fifth", "Sixth", "Seventh", _

				  "Eighth", "Nineth", "Tenth", "Eleventh", "Twelfth", "Thirteenth", _

				  "Fourteenth", "Fifteenth", "Sixteenth", "Seventeenth", "Eighteenth", _

				  "Nineteenth", "Twentieth", "Twenty-first", "Twenty-second", "Twenty-third", _

				  "Twenty-fourth", "Twenty-fifth", "Twenty-sixth", "Twenty-seventh", _

				  "Twenty-eighth", "Twenty-nineth", "Thirtieth", "Thirty-first")

  Cardinal = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", _

				   "Nine", "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", _

				   "Sixteen", "Seventeen", "Eighteen", "Nineteen")

  Tens = Array("Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")

  If Len(DateIn) = 0 Then Exit Function

  If TypeOf Application.Caller Is Range Then

    '  The date serial number that Excel's worksheet thinks is for 2/29/1900

    '  is actually the date serial number that VB thinks is for 2/28/1900

    If Format([DateIn], "m/d/yyyy") = "2/28/1900" Then

	  DateToWords = "Twenty-nineth of February, One Thousand Nine Hundred"

	  Exit Function

    ElseIf DateIn < DateSerial(1900, 3, 1) Then

	  If TypeOf Application.Caller Is Range Then DateIn = DateIn + 1

    End If

  End If

  DateIn = CDate(DateIn)

  Yrs = CStr(Year(DateIn))

  Decades = Mid$(Yrs, 3)

  If CInt(Decades) < 20 Then

    Decades = Cardinal(CInt(Decades))

  Else

    Decades = Tens(CInt(Left$(Decades, 1)) - 2) & "-" & Cardinal(CInt(Right$(Decades, 1)))

    If Right(Decades, 1) = "-" Then Decades = Left(Decades, Len(Decades) - 1)

  End If

  Hundreds = Mid$(Yrs, 2, 1)

  If CInt(Hundreds) Then

    Hundreds = Cardinal(CInt(Hundreds)) & " Hundred "

  Else

    Hundreds = ""

  End If

  DateToWords = Ordinal(Day(DateIn) - 1) & " of " & Choose(Month(DateIn), "January", _

			    "February", "March", "April", "May", "June", "July", "August", _

			    "September", "October", "November", "December") & ", " & _

			    Cardinal(CInt(Left$(Yrs, 1))) & " Thousand " & Hundreds & Decades

End Function

**الـعيدروس** · ديسمبر 14, 2012

السلام عليكم

بعد اذن اخي الحبيب ياسر خليل

هذه محاولة

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

تدرج الاكود التالية في مودويل

استعمال المعادلة كالاتي


=Ali_IsD(خلية التاريخ)


Private Const MyBegTx As String = ""

Private Const MyTNum As String = "ألف"

Private Const Ad As String = " في اليوم "

Private Const Am As String = " من شهر "

Private Const Ay As String = " عام "

Public Function Ali_IsD(ByVal S_D As Range) As String

Dim Ar(), Arr(), Ar1(), Arr1()

Dim Dy, Mn, Ya, Mr, R_S

Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر")

'********************************************

Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _

, "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _

, "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _

, "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين")

If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function

    For Rr = LBound(Arr) To UBound(Arr)

	  If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For

    Next

    For Mr = LBound(Ar) To UBound(Ar)

	  If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For

    Next

    Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D))

End Function

Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String

Dim Spp, zt

Dim i%, ii%, pr%

Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$

'======================================

If Not IsNumeric(Num) Then GoTo kh_Exit

Spp = Split("/" & MyTNum, "/")

ii = UBound(Spp)

If Num < 0 Then Num = Abs(Num)

'======================================

If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit

'======================================

nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr))

'======================================

Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")

For i = 0 To ii

    MyMid = Mid(Txt1, (i * 3) + 1, 3)

    If MyMid Then

	    zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))

	    zt = IIf(ii - i, Int(zt), zt)

	    Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)

	    pr = 1 + IIf(ii - i, 1, CInt(sex))

	    Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> ""))

    End If

    If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", " ") & sNameCurr

Next

'======================================

Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count)

'======================================

kh_Exit:

kh_TextNum = Trim(Txt)

End Function

Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String

Dim Sp

Dim Num1%, Num2%, Num3%

Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$

'======================================

Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")

'======================================

If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"

oM = Trim(Split(oMm, "-")(0))

'======================================

Num1 = Left(iNum, 1)

Num2 = Right(iNum, 2)

Select Case Num1

    Case 1:	  nT0 = "مائة"

    Case 2:	  nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))

    Case 3 To 9: nT0 = Sp(Num1) & "مائة"

End Select

'=========================================

Num1 = Right(iNum, 2)

Select Case Num1

    Case 1, 2:	 If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM

    Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً"

End Select

'-----------------------------------------

Select Case Num1

    Case 1

	    nT = IIf(oM = "", Sp(0) & S1, oM)

	    oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")

    Case 2

	    nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ين"))

	    oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")

    Case 3 To 10

	    oM = Trim(Split(oMm, "-")(1))

	    nT = Sp(Num1) & S

    Case 11, 12

	    nT = Sp(Num1) & Sp(10) & S1

    Case 13 To 19

	    nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1

    Case 20 To 99

	    Num2 = Right(Num1, 1)

	    Num3 = Left(Num1, 1)

	    If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"

	    nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1

	    If Num2 = 0 Then nT2 = nT1

	    nT = nT2

End Select

'======================================

S = IIf(nT = "" Or iNum < 100, "", " و")

nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")

kh_nText = Trim(nT0 & S & nT & " " & oM)

'======================================

End Function

Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String

Dim Td$, Td1$

On Error GoTo 1

If NCur = "" Then Ndec = ""

Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))

If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1

If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td

Td1 = "  و " & Chr(40) & Td1 & Chr(41) & Ndec

1: kh_dText = Td1

End Function

تحويل التاريخ حروف _A.rar

تم تعديل ديسمبر 14, 2012 بواسطه عباد

ياسر خليل أبو البراء · ديسمبر 14, 2012

بارك الله فيك أخي الغالي

عند عمل اختبار للدالة التي تفضلت بها

جربت التاريخ 1/1/2012 فكانت النتيجة

 في اليوم 2012 من شهر جانفي عام واحد

**الـعيدروس** · ديسمبر 14, 2012

السلام عليكم

اخي الحبيب ياسر الخليل

اشكر على هذه الملاحظة القيمة

اذا التاريخ يكتب البداية السنه

التعديل في المعادلة الاول كالتالي


Public Function Ali_IsD(ByVal S_D As Range) As String

Dim Ar(), Arr(), Ar1(), Arr1()

Dim Dy, Mn, Ya, Mr, R_S

Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر")

'********************************************

Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _

, "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _

, "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _

, "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين")

If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function

    For Rr = LBound(Arr) To UBound(Arr)

	  If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For

    Next

    For Mr = LBound(Ar) To UBound(Ar)

	  If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For

    Next

    Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D))

End Function

تم تعديل ديسمبر 14, 2012 بواسطه عباد

ياسر خليل أبو البراء · ديسمبر 14, 2012

تسلم الأيادي

هو دا الكلام يا كبير

**الـعيدروس** · ديسمبر 14, 2012

اشكرك اخي ياسر على كلماتك الطيبه

وهذا التعديل الاخير للداله لكل الحالات


Private Const MyBegTx As String = ""

Private Const MyTNum As String = "ألف"

Private Const Ad As String = " في اليوم "

Private Const Am As String = " من شهر "

Private Const Ay As String = " عام "

Public Function Ali_IsD(ByVal S_D As Range) As String

Dim Ar(), Arr(), Ar1(), Arr1()

Dim Dy, Mn, Ya, Mr, R_S

Ar = Array("جانفي", "فيفري", "مارس", "افريل", "ماي", "جوان", "جويلية", "اوت", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر")

'********************************************

Arr = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر" _

, "الحادي عشر", "الثاني عشر", "الثالث عشر", "الرابع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر" _

, "التاسع عشر", "العشرين", "الواحد والعشرين", "الثاني والعشرين", "الثالث والعشرين", "الرابع والعشرين" _

, "الخامس والعشرين", "السادس والعشرين", "السابع والعشرين", "الثامن والعشرين", "التاسع والعشرين", "الثلاثين", "الواحد والثلاثين")

If InStr(S_D.Text, "/") = 0 Then MsgBox "القيمة المدخلة ليس بصيغة تاريخ", vbExclamation, "تنبية !!!": Exit Function

For Rr = LBound(Arr) To UBound(Arr)

	 If CLng(Day(S_D)) = Rr + 1 Then Dy = Arr(Rr): Exit For

Next

For Mr = LBound(Ar) To UBound(Ar)

	 If CLng(Month(S_D)) = Mr + 1 Then Mn = Ar(Mr): Exit For

Next

Ali_IsD = Ad & Dy & Am & Mn & Ay & kh_TextNum(Year(S_D))

End Function

من حمل مرفق المشاركة السابقة

يرجاء تحميل المرفق مرة اخرى

وأي ملاحظات انا موجود

تم تعديل ملاحظت اخي يوسف عطا

تقبلو تحياتي وشكري

تحويل التاريخ حروف _A.rar

تم تعديل ديسمبر 15, 2012 بواسطه عباد

**يوسف عطا** · ديسمبر 14, 2012

السلام عليكم

أخى عباد

اليوم التاسع غير موجود بالكود

للتنويه فقط

تقبل تحياتى

**الـعيدروس** · ديسمبر 14, 2012

اخي الحبيب يوسف عطا

جزاك الله خير على الملحوظة القيمة

تم تعديل مرفقات المشاركه السابقة

**ريان أحمد** · ديسمبر 15, 2012

جزاكم الله كل خير على المجهودات الجبارة التي تبذلونها

أبو ردينة · ديسمبر 16, 2012

بارك الله في جميع الإخوة الأحباب أساتذتنا الكرام

السؤال لأخي الكريم أستاذ / عبد الله باقشير و الجميع

هل يمكن إضافة تعديل يسمح بالتحويل من الهجري للميلادي و العكس ؟

تسجيل الدخول

كيفية كتابة تاريخ بالحروف

الردود الموصى بها

عبد الغني1

الـعيدروس

عبد الغني1

ياسر خليل أبو البراء

الـعيدروس

ياسر خليل أبو البراء

الـعيدروس

ياسر خليل أبو البراء

الـعيدروس

يوسف عطا

الـعيدروس

ريان أحمد

أبو ردينة

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information