تحويل الوحدة النمطية من الانجليزي الى العربي

[sm44ms]

الرجاء تحويل الوحدة النمطية كما هي من الانجليزي الى العربية  بالدرهم

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

Function ConvertCurrencyToArbaic(ByVal MyNumber)
  Dim Temp
         Dim AED, Cents
         Dim DecimalPlace, Count
         ReDim Place(9) As String
         Place(2) = " Thousand "
         Place(3) = " Million "
         Place(4) = " Billion "
         Place(5) = " Trillion "
         MyNumber = Trim(Str(MyNumber))
         DecimalPlace = InStr(MyNumber, ".")
        If DecimalPlace > 0 Then
         Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
            Cents = ConvertTens(Temp)
            MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
         End If
         Count = 1
         Do While MyNumber <> ""
            Temp = ConvertHundreds(Right(MyNumber, 3))
            If Temp <> "" Then AED = Temp & Place(Count) & AED
            If Len(MyNumber) > 3 Then
               MyNumber = Left(MyNumber, Len(MyNumber) - 3)
            Else
               MyNumber = ""
            End If
            Count = Count + 1
         Loop
         Select Case AED ''يمكنك وضع أي عملة تريدها بدلا من الدولار طبعا بالنجليزي
            Case ""
               AED = "No AED"
            Case "One"
               AED = "One AED"
            Case Else
               AED = AED & " AED"
         End Select
         Select Case Cents
         Case ""
         Cents = ""
           Case "One"
               Cents = " And One Cent"
            Case Else
               Cents = " And " & Cents & " Cents"
         End Select
         ConvertCurrencyToArbaic = AED & Cents
End Function
Private Function ConvertDigit(ByVal MyDigit)
        Select Case Val(MyDigit)
            Case 1: ConvertDigit = "One"
            Case 2: ConvertDigit = "Two"
            Case 3: ConvertDigit = "Three"
            Case 4: ConvertDigit = "Four"
            Case 5: ConvertDigit = "Five"
            Case 6: ConvertDigit = "Six"
            Case 7: ConvertDigit = "Seven"
            Case 8: ConvertDigit = "Eight"
            Case 9: ConvertDigit = "Nine"
            Case Else: ConvertDigit = ""
         End Select
End Function
Private Function ConvertHundreds(ByVal MyNumber)
    Dim Result As String
         If Val(MyNumber) = 0 Then Exit Function
         MyNumber = Right("000" & MyNumber, 3)
         If Left(MyNumber, 1) <> "0" Then
            Result = ConvertDigit(Left(MyNumber, 1)) & " Hundred "
         End If
         If Mid(MyNumber, 2, 1) <> "0" Then
            Result = Result & ConvertTens(Mid(MyNumber, 2))
         Else
            Result = Result & ConvertDigit(Mid(MyNumber, 3))
         End If
         ConvertHundreds = Trim(Result)
End Function
Private Function ConvertTens(ByVal MyTens)
          Dim Result As String
         If Val(Left(MyTens, 1)) = 1 Then
            Select Case Val(MyTens)
               Case 10: Result = "Ten"
               Case 11: Result = "Eleven"
               Case 12: Result = "Twelve"
               Case 13: Result = "Thirteen"
               Case 14: Result = "Fourteen"
               Case 15: Result = "Fifteen"
               Case 16: Result = "Sixteen"
               Case 17: Result = "Seventeen"
               Case 18: Result = "Eighteen"
               Case 19: Result = "Nineteen"
               Case Else
            End Select
         Else
          
            Select Case Val(Left(MyTens, 1))
               Case 2: Result = "Twenty "
               Case 3: Result = "Thirty "
               Case 4: Result = "Forty "
               Case 5: Result = "Fifty "
               Case 6: Result = "Sixty "
               Case 7: Result = "Seventy "
               Case 8: Result = "Eighty "
               Case 9: Result = "Ninety "
               Case Else
            End Select
            Result = Result & ConvertDigit(Right(MyTens, 1))
         End If
         ConvertTens = Result
End Function

 

[Foksh]

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

Function ConvertCurrencyToArabic(ByVal MyNumber)
    Dim Temp
    Dim AED, Cents
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " ألف "
    Place(3) = " مليون "
    Place(4) = " مليار "
    Place(5) = " تريليون "
    
    MyNumber = Trim(Str(MyNumber))
    DecimalPlace = InStr(MyNumber, ".")
    
    If DecimalPlace > 0 Then
        Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
        Cents = ConvertTens(Temp)
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    
    Count = 1
    
    Do While MyNumber <> ""
        Temp = ConvertHundreds(Right(MyNumber, 3))
        
        If Temp <> "" Then
            AED = Temp & Place(Count) & AED
        End If
        
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        
        Count = Count + 1
    Loop
    
    Select Case AED
        Case ""
            AED = "لا يوجد درهم"
        Case "One"
            AED = "درهم واحد"
        Case Else
            AED = AED & " درهم"
    End Select
    
    Select Case Cents
        Case ""
            Cents = ""
        Case "One"
            Cents = " "
        Case Else
            Cents = " و" & Cents & " "
    End Select
    
    ConvertCurrencyToArabic = AED & Cents
End Function

Private Function ConvertDigit(ByVal MyDigit)
    Select Case Val(MyDigit)
        Case 1: ConvertDigit = "واحد"
        Case 2: ConvertDigit = "اثنان"
        Case 3: ConvertDigit = "ثلاثة"
        Case 4: ConvertDigit = "أربعة"
        Case 5: ConvertDigit = "خمسة"
        Case 6: ConvertDigit = "ستة"
        Case 7: ConvertDigit = "سبعة"
        Case 8: ConvertDigit = "ثمانية"
        Case 9: ConvertDigit = "تسعة"
        Case Else: ConvertDigit = ""
    End Select
End Function

Private Function ConvertHundreds(ByVal MyNumber)
    Dim Result As String
    
    If Val(MyNumber) = 0 Then Exit Function
    
    MyNumber = Right("000" & MyNumber, 3)
    
    If Left(MyNumber, 1) <> "0" Then
        Result = ConvertDigit(Left(MyNumber, 1)) & " مئة "
    End If
    
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & ConvertTens(Mid(MyNumber, 2))
    Else
        Result = Result & ConvertDigit(Mid(MyNumber, 3))
    End If
    
    ConvertHundreds = Trim(Result)
End Function

Private Function ConvertTens(ByVal MyTens)
    Dim Result As String
    
    If Val(Left(MyTens, 1)) = 1 Then
        Select Case Val(MyTens)
            Case 10: Result = "عشرة"
            Case 11: Result = "أحد عشر"
            Case 12: Result = "اثنا عشر"
            Case 13: Result = "ثلاثة عشر"
            Case 14: Result = "أربعة عشر"
            Case 15: Result = "خمسة عشر"
            Case 16: Result = "ستة عشر"
            Case 17: Result = "سبعة عشر"
            Case 18: Result = "ثمانية عشر"
            Case 19: Result = "تسعة عشر"
            Case Else
        End Select
    Else
        Select Case Val(Left(MyTens, 1))
            Case 2: Result = "عشرون "
            Case 3: Result = "ثلاثون "
            Case 4: Result = "أربعون "
            Case 5: Result = "خمسون "
            Case 6: Result = "ستون "
            Case 7: Result = "سبعون "
            Case 8: Result = "ثمانون "
            Case 9: Result = "تسعون "
            Case Else
        End Select
        
        Result = Result & ConvertDigit(Right(MyTens, 1))
    End If
    
    ConvertTens = Result
End Function

وهذا مرفق لكود آخر للتفقيط بالعربي

 

تفقيط الارقام فى الاكسس.accdb

تم تعديل ديسمبر 11, 2023 بواسطه Foksh

[sm44ms]

سوف اجرب وارد لك بارك الله فيك والف شكر مقدما

[sm44ms]

فيه خطا ء بسيط لو تشوفه جزاك الله خير

يوجد خطاء في ترتيب القيمة بالاضافة الى ذلك لايوجد قيمة الفلس

وشكرا

[sm44ms]

افضل التعديل على الودحة الي ارسلتها انا جزاك الله خير

[kkhalifa1960]

مشاركة بطلبك .

DD437.rar

[sm44ms]

الف شكر  تمت التجربة

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

[sm44ms]

شوف المشكلة وين انا جربت الوحدات النمطية الثنتين

 

 

تم تعديل ديسمبر 13, 2023 بواسطه sm44ms

[محمد احمد لطفى]

تفضل عدل العملة فقط فى النموذج

 

تفقيط الارقام فى الاكسس.accdb

[sm44ms]

انا اتكلم على مشاركة الاخ الاستاذ خليفه

ابا تعديل عليها شوف المرفق 

واكتب 52.50

DD437.accdb

[kkhalifa1960]

انشاء الله بس ارجع البيت. ابشر

[kkhalifa1960]

تفضل أخي @sm44ms المرفق بعد التعديل .

DD437-1.rar

[sm44ms]

مشكوووووورين

[kkhalifa1960]

اذا كان هذ طلبك لا تنسى الضغط على أفضل اجابة .

[sm44ms]

الاخ خليفه سوال

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

[kkhalifa1960]

ما عليك شكراً .

[Moosak]

في 15‏/12‏/2023 at 09:02, sm44ms said:

الاخ خليفه سوال

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

ستجد عبارة اختر كأفضل إجابة اسفل كل مشاركة ..

         

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

🙂

[sm44ms]

جزاك الله خير

وصباحكم طيب