اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

دالة التاريخ كتابة بدل الرقم

عمر طاهر

بواسطه عمر طاهر
في قسم الأكسيس Access

 مشاركة

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

عبدالقدوس48

عبدالقدوس48

قام بنشر
قام بنشر

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

يوجد دالة الفرنسية

أنت غير فيها

Function ConversionHeures(Nombre As Integer) As String

    If Nombre = 0 Or Nombre = 24 Then
        ConversionHeures = "Minuit "
         Exit Function
        ElseIf Nombre = 12 Then
        ConversionHeures = "Midi "
        Exit Function
    End If

        
    Const stEspace As String = " "
    Dim Varnum, VarnumD, VarnumU, Resultat, Varlet

    Static Chiffre(1 To 19)
    Chiffre(1) = "une"
    Chiffre(2) = "deux"
    Chiffre(3) = "trois"
    Chiffre(4) = "quatre"
    Chiffre(5) = "cinq"
    Chiffre(6) = "six"
    Chiffre(7) = "sept"
    Chiffre(8) = "huit"
    Chiffre(9) = "neuf"
    Chiffre(10) = "dix"
    Chiffre(11) = "onze"
    Chiffre(12) = "douze"
    Chiffre(13) = "treize"
    Chiffre(14) = "quatorze"
    Chiffre(15) = "quinze"
    Chiffre(16) = "seize"
    Chiffre(17) = "dix-sept"
    Chiffre(18) = "dix-huit"
    Chiffre(19) = "dix-neuf"

    Static dizaine(1 To 9, 1 To 5)
    dizaine(1, 1) = "dix"
    dizaine(2, 1) = "vingt"
    dizaine(3, 1) = "trente"
    dizaine(4, 1) = "quarante"
    dizaine(5, 1) = "cinquante"
    dizaine(6, 1) = "soixante"
    dizaine(7, 1) = "soixante"
    dizaine(8, 1) = "quatre-vingt"
    dizaine(9, 1) = "quatre-vingt"

    Resultat = ""
    Varnum = Int(Nombre) Mod 1000
    If Varnum > 0 Then
        GoSub centaine_dizaine
        Resultat = Resultat + " " + Varlet
    End If
    Resultat = LTrim(Resultat)
    Varlet = Right$(Resultat, 4)
    'traitement du "s" final pour vingt et cent
    Select Case Varlet
        Case "cent", "ingt"
            Resultat = Resultat + "s"
    End Select


FinTraitement:
    Resultat = Resultat + stEspace
    'renvoi du résultat de la fonction et fin de la fonction
    ConversionHeures = Replace(Resultat, "  ", " ")
    Exit Function

    'sous programme
centaine_dizaine:
    Varlet = ""

    'traitement des centaines
    If Varnum >= 100 Then
        Varlet = Chiffre(Int(Varnum / 100))
        Varnum = Varnum Mod 100
        If Varlet = "un" Then
            Varlet = "cent "
        Else
            Varlet = Varlet + " cent "
        End If
    End If

    'traitement des dizaines
        If Varnum <= 19 Then
            If Varnum > 0 Then: Varlet = Varlet + Chiffre(Varnum)
        Else
            VarnumD = Int(Varnum / 10)
            VarnumU = Varnum Mod 10
            Varlet = Varlet + dizaine(VarnumD, 1)
            If VarnumU = 1 And VarnumD < 8 Then
                Varlet = Varlet + " et "
            Else
                If VarnumU <> 0 Or VarnumD = 7 Or VarnumD = 9 Then: Varlet = Varlet & " "
            End If
            If VarnumD = 7 Or VarnumD = 9 Then: VarnumU = VarnumU + 10
            If VarnumU <> 0 Then: Varlet = Varlet + Chiffre(VarnumU)
        End If
        Varlet = Trim(Varlet)
        Return
End Function
 

للعم الشهر يأخذه من نظام الكمبيوتر

  • Like 1
رابط هذا التعليق
شارك
Moosak

Moosak

قام بنشر
قام بنشر

استخدم هذا الكود أخي عمر .. وهو بالعربي .. 

تضعه في موديول منفصل ثم تستدعيه كما هو موضح بالأسفل

مثال :

image.png.2b79747d7c4e70f3dfaaca7650015a01.png 

Public Function DateAsText(GivenDate As Date) As String

Dim Daytxt, Monthtxt, Yeartxt As String

Daytxt = NoToTxt(Day(GivenDate), "", "")
'Monthtxt = "من شهر " & NoToTxt(Month(GivenDate), "", "") ' فعل هذا السطر إذا أردت كتابة الشهر بالرقم وليس بالاسم
Monthtxt = "من شهر " & MonthName(Month(GivenDate))
Yeartxt = "سنة" & NoToTxt(Year(GivenDate), "", "")
DateAsText = Daytxt & "" & Monthtxt & " " & Yeartxt & "ميلادي"

End Function


Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry1(0 To 9) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim MyNo As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim i As Integer
Dim ReMark As String


If TheNo > 999999999999.99 Then Exit Function


If TheNo = 0 Then
NoToTxt = "صفر"
Exit Function
End If

MyAnd = " و"
MyArry1(0) = ""
MyArry1(1) = "مائة"
MyArry1(2) = "مائتان"
MyArry1(3) = "ثلاثمائة"
MyArry1(4) = "أربعمائة"
MyArry1(5) = "خمسمائة"
MyArry1(6) = "ستمائة"
MyArry1(7) = "سبعمائة"
MyArry1(8) = "ثمانمائة"
MyArry1(9) = "تسعمائة"

MyArry2(0) = ""
MyArry2(1) = " عشر"
MyArry2(2) = "عشرون"
MyArry2(3) = "ثلاثون"
MyArry2(4) = "أربعون"
MyArry2(5) = "خمسون"
MyArry2(6) = "ستون"
MyArry2(7) = "سبعون"
MyArry2(8) = "ثمانون"
MyArry2(9) = "تسعون"

MyArry3(0) = ""
MyArry3(1) = "واحد"
MyArry3(2) = "اثنان"
MyArry3(3) = "ثلاثة"
MyArry3(4) = "أربعة"
MyArry3(5) = "خمسة"
MyArry3(6) = "ستة"
MyArry3(7) = "سبعة"
MyArry3(8) = "ثمانية"
MyArry3(9) = "تسعة"
'======================

GetNo = Format(TheNo, "000000000000.00")

i = 0
Do While i < 15

If i < 12 Then
MyNo = Mid$(GetNo, i + 1, 3)
Else
MyNo = "0" + Mid$(GetNo, i + 2, 2)
End If

If (Mid$(MyNo, 1, 3)) > 0 Then

RdNo = Mid$(MyNo, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(MyNo, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(MyNo, 2, 1)
My10 = MyArry2(RdNo)

If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر"
If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر"
If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة"

If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd

GetTxt = My100 + My1 + My10

If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11
End If

If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12
End If

If (i = 0) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
Mybillion = GetTxt + " مليار"
Else
Mybillion = GetTxt + " مليارات"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران"
End If
End If

If (i = 3) And (GetTxt <> "") Then

If ((Mid$(MyNo, 1, 3)) > 10) Then
MyMillion = GetTxt + " مليون"
Else
MyMillion = GetTxt + " ملايين"
If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون"
If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان"
End If
End If

If (i = 6) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
MyThou = GetTxt + " ألف"
Else
MyThou = GetTxt + " آلاف"
If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف"
If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان"
End If
End If

If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If

i = i + 3
Loop

If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If

If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If

If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If

If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt = ReMark + MyFraction + " " + MySubCur
End If
Else
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If

End Function

وطريقة استدعائه (كمصدر للخلية أو في الاستعلام) كالتالي : 

= DateAsText([Date])

 

  • Like 2
رابط هذا التعليق
شارك
الحلبي

الحلبي

قام بنشر
قام بنشر

استاذنا/ @Moosak

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

جزاك الله كل خير

رابط هذا التعليق
شارك
jjafferr

jjafferr

قام بنشر
قام بنشر
1 دقيقه مضت, الحلبي said:

نسخ المويل يطلع كل الكلام بالعربى الى علامات استفهام

دكتور حلبي 🙂

راح اخبرك سر ، وبس اخبره للعزيزين 🙂

 

تأكد من ان لغة لوحة المفاتيح باللغة العربية عند النسخ 

image.png.0bf0f18b618173a643e557bdc29de41d.png

.

وكذلك عند اللصق 🙂

 

جعفر

  • Like 3
رابط هذا التعليق
شارك
الحلبي

الحلبي

قام بنشر
قام بنشر
14 دقائق مضت, jjafferr said:

راح اخبرك سر ، وبس اخبره للعزيزين

سر غالى من اخ ومعلم غالى

الله يرضى عنك ويرزقك من غير حساب 

ولكن سؤالى : هو مفيش حاجة  فى الكمبيوتر  ما تعرفهاش ـ كل شئ تعرفه

 

ا

10 دقائق مضت, Moosak said:

تفضل يا حلبي

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

جزاكم الله كل خير

  • Thanks 1
رابط هذا التعليق
شارك
jjafferr

jjafferr

قام بنشر
قام بنشر
منذ ساعه, الحلبي said:

ولكن سؤالى : هو مفيش حاجة  فى الكمبيوتر  ما تعرفهاش ـ كل شئ تعرفه

ياااه ، ذكرتني بأيام زماااان 🙂

 

منذ ساعه, الحلبي said:
منذ ساعه, ازهر عبد العزيز said:

مشعوذ 

وانت الصادق

مبدع وعبقرى وفنان

المهم اني اعرف ان المقصود هو جعفر 🙂

 

رابط هذا التعليق
شارك
عمر طاهر

عمر طاهر

قام بنشر
  • الكاتب
قام بنشر
19 ساعات مضت, عبدالقدوس48 said:

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

يوجد دالة الفرنسية

أنت غير فيها

Function ConversionHeures(Nombre As Integer) As String

    If Nombre = 0 Or Nombre = 24 Then
        ConversionHeures = "Minuit "
         Exit Function
        ElseIf Nombre = 12 Then
        ConversionHeures = "Midi "
        Exit Function
    End If

        
    Const stEspace As String = " "
    Dim Varnum, VarnumD, VarnumU, Resultat, Varlet

    Static Chiffre(1 To 19)
    Chiffre(1) = "une"
    Chiffre(2) = "deux"
    Chiffre(3) = "trois"
    Chiffre(4) = "quatre"
    Chiffre(5) = "cinq"
    Chiffre(6) = "six"
    Chiffre(7) = "sept"
    Chiffre(8) = "huit"
    Chiffre(9) = "neuf"
    Chiffre(10) = "dix"
    Chiffre(11) = "onze"
    Chiffre(12) = "douze"
    Chiffre(13) = "treize"
    Chiffre(14) = "quatorze"
    Chiffre(15) = "quinze"
    Chiffre(16) = "seize"
    Chiffre(17) = "dix-sept"
    Chiffre(18) = "dix-huit"
    Chiffre(19) = "dix-neuf"

    Static dizaine(1 To 9, 1 To 5)
    dizaine(1, 1) = "dix"
    dizaine(2, 1) = "vingt"
    dizaine(3, 1) = "trente"
    dizaine(4, 1) = "quarante"
    dizaine(5, 1) = "cinquante"
    dizaine(6, 1) = "soixante"
    dizaine(7, 1) = "soixante"
    dizaine(8, 1) = "quatre-vingt"
    dizaine(9, 1) = "quatre-vingt"

    Resultat = ""
    Varnum = Int(Nombre) Mod 1000
    If Varnum > 0 Then
        GoSub centaine_dizaine
        Resultat = Resultat + " " + Varlet
    End If
    Resultat = LTrim(Resultat)
    Varlet = Right$(Resultat, 4)
    'traitement du "s" final pour vingt et cent
    Select Case Varlet
        Case "cent", "ingt"
            Resultat = Resultat + "s"
    End Select


FinTraitement:
    Resultat = Resultat + stEspace
    'renvoi du résultat de la fonction et fin de la fonction
    ConversionHeures = Replace(Resultat, "  ", " ")
    Exit Function

    'sous programme
centaine_dizaine:
    Varlet = ""

    'traitement des centaines
    If Varnum >= 100 Then
        Varlet = Chiffre(Int(Varnum / 100))
        Varnum = Varnum Mod 100
        If Varlet = "un" Then
            Varlet = "cent "
        Else
            Varlet = Varlet + " cent "
        End If
    End If

    'traitement des dizaines
        If Varnum <= 19 Then
            If Varnum > 0 Then: Varlet = Varlet + Chiffre(Varnum)
        Else
            VarnumD = Int(Varnum / 10)
            VarnumU = Varnum Mod 10
            Varlet = Varlet + dizaine(VarnumD, 1)
            If VarnumU = 1 And VarnumD < 8 Then
                Varlet = Varlet + " et "
            Else
                If VarnumU <> 0 Or VarnumD = 7 Or VarnumD = 9 Then: Varlet = Varlet & " "
            End If
            If VarnumD = 7 Or VarnumD = 9 Then: VarnumU = VarnumU + 10
            If VarnumU <> 0 Then: Varlet = Varlet + Chiffre(VarnumU)
        End If
        Varlet = Trim(Varlet)
        Return
End Function
 

للعم الشهر يأخذه من نظام الكمبيوتر

الاستدعاء ...؟

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

استخدم هذا الكود أخي عمر .. وهو بالعربي .. 

تضعه في موديول منفصل ثم تستدعيه كما هو موضح بالأسفل

مثال :

image.png.2b79747d7c4e70f3dfaaca7650015a01.png 

Public Function DateAsText(GivenDate As Date) As String

Dim Daytxt, Monthtxt, Yeartxt As String

Daytxt = NoToTxt(Day(GivenDate), "", "")
'Monthtxt = "من شهر " & NoToTxt(Month(GivenDate), "", "") ' فعل هذا السطر إذا أردت كتابة الشهر بالرقم وليس بالاسم
Monthtxt = "من شهر " & MonthName(Month(GivenDate))
Yeartxt = "سنة" & NoToTxt(Year(GivenDate), "", "")
DateAsText = Daytxt & "" & Monthtxt & " " & Yeartxt & "ميلادي"

End Function


Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry1(0 To 9) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim MyNo As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim i As Integer
Dim ReMark As String


If TheNo > 999999999999.99 Then Exit Function


If TheNo = 0 Then
NoToTxt = "صفر"
Exit Function
End If

MyAnd = " و"
MyArry1(0) = ""
MyArry1(1) = "مائة"
MyArry1(2) = "مائتان"
MyArry1(3) = "ثلاثمائة"
MyArry1(4) = "أربعمائة"
MyArry1(5) = "خمسمائة"
MyArry1(6) = "ستمائة"
MyArry1(7) = "سبعمائة"
MyArry1(8) = "ثمانمائة"
MyArry1(9) = "تسعمائة"

MyArry2(0) = ""
MyArry2(1) = " عشر"
MyArry2(2) = "عشرون"
MyArry2(3) = "ثلاثون"
MyArry2(4) = "أربعون"
MyArry2(5) = "خمسون"
MyArry2(6) = "ستون"
MyArry2(7) = "سبعون"
MyArry2(8) = "ثمانون"
MyArry2(9) = "تسعون"

MyArry3(0) = ""
MyArry3(1) = "واحد"
MyArry3(2) = "اثنان"
MyArry3(3) = "ثلاثة"
MyArry3(4) = "أربعة"
MyArry3(5) = "خمسة"
MyArry3(6) = "ستة"
MyArry3(7) = "سبعة"
MyArry3(8) = "ثمانية"
MyArry3(9) = "تسعة"
'======================

GetNo = Format(TheNo, "000000000000.00")

i = 0
Do While i < 15

If i < 12 Then
MyNo = Mid$(GetNo, i + 1, 3)
Else
MyNo = "0" + Mid$(GetNo, i + 2, 2)
End If

If (Mid$(MyNo, 1, 3)) > 0 Then

RdNo = Mid$(MyNo, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(MyNo, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(MyNo, 2, 1)
My10 = MyArry2(RdNo)

If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر"
If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر"
If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة"

If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd

GetTxt = My100 + My1 + My10

If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11
End If

If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12
End If

If (i = 0) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
Mybillion = GetTxt + " مليار"
Else
Mybillion = GetTxt + " مليارات"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار"
If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران"
End If
End If

If (i = 3) And (GetTxt <> "") Then

If ((Mid$(MyNo, 1, 3)) > 10) Then
MyMillion = GetTxt + " مليون"
Else
MyMillion = GetTxt + " ملايين"
If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون"
If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان"
End If
End If

If (i = 6) And (GetTxt <> "") Then
If ((Mid$(MyNo, 1, 3)) > 10) Then
MyThou = GetTxt + " ألف"
Else
MyThou = GetTxt + " آلاف"
If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف"
If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان"
End If
End If

If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If

i = i + 3
Loop

If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If

If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If

If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If

If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt = ReMark + MyFraction + " " + MySubCur
End If
Else
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If

End Function

وطريقة استدعائه (كمصدر للخلية أو في الاستعلام) كالتالي : 

= DateAsText([Date])

 

مشكور جهدك اخي

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept