+- منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب (https://vb4arb.com/vb)
+-- قسم : الاقسام الاخرى (https://vb4arb.com/vb/forumdisplay.php?fid=74)
+--- قسم : قسم برمجة وتطوير تطبيقات الأندرويد (https://vb4arb.com/vb/forumdisplay.php?fid=75)
+--- الموضوع : تحويل الرقم الىكتابة (/showthread.php?tid=44387)
تحويل الرقم الىكتابة - ayam - 28-11-22
تحية طيبة
ارجو منكم المساعدة في تعديل كود الاكسس الخاص بتحويل الرقم الى كتابة مثلا اذا كان الرقم فيه كسور عشرية
قراءة الكسور
مثلا
Option Explicit
Function ConvertCurrencyToEnglish(ByVal Amount)
Dim Temp
Dim Derhams, Fils
Dim DecimalPlace, Count
Dim tmpAmount As Integer
ReDim Place(9) As String
Place(2) = " الاف"
Place(3) = " مليون"
Place(4) = " مليار"
Place(5) = " ترليون"
' Convert Amount to a string, trimming extra spaces.
Amount = Trim(Format(Amount, "#########"))
tmpAmount = CInt(Right(Amount, 2))
' Find decimal place.
DecimalPlace = InStr(Amount, ".")
' If we find decimal place...
If DecimalPlace > 0 Then
' Convert Fils
Temp = Left(Mid(Amount, DecimalPlace + 1) & "00", 2)
Fils = ConvertTens(Temp)
' Strip off Fils from remainder to convert.
Amount = Trim(Left(Amount, DecimalPlace - 1))
End If
Count = 1
Do While Amount <> ""
' Convert last 3 digits of Amount to English Derhams.
If Count < 2 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" Then Derhams = Temp & Place(Count) & Derhams
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 2 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "الف " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "الفا ", "الفان ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " الاف", " الفا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 3 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "مليون " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "مليونا ", "مليونان ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " ملايين", " مليونا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 4 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "مليار " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "مليارا ", "ملياران ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " مليارات", " مليارا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
End If
Count = Count + 1
Loop
' Clean up Derhams.
Select Case Derhams
Case ""
Derhams = "صفر دينار"
Case "واحد"
Derhams = "دينار واحد"
Case "اثنان"
Derhams = "ديناران"
Case Else
Derhams = " " & Derhams & IIf(tmpAmount > 0 And tmpAmount < 11, " دنانير", " دينار")
End Select
Derhams = Derhams + " لا غير"
' Clean up Fils.
Select Case Fils
Case ""
Fils = " دينار, صفر فلس"
Case "One"
Fils = " And One Fils"
Case Else
Fils = " And " & Fils & " Fils"
End Select
ConvertCurrencyToEnglish = Derhams
End Function
Private Function ConvertHundreds(ByVal Amount)
Dim result As String
' Exit if there is nothing to convert.
If Val(Amount) = 0 Then Exit Function
' Append leading zeros to number.
Amount = Right("000" & Amount, 3)
' Do we have a hundreds place digit to convert?
If Left(Amount, 1) <> "0" Then
Select Case Left(Amount, 1)
Case 1: result = "مئة"
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
End If
' Do we have a tens place digit to convert?
If Mid(Amount, 2, 1) <> "0" Then
result = result & IIf(result = "" Or Right(Amount, 2) = "00", "", " و") & ConvertTens(Mid(Amount, 2))
Else
' If not, then convert the ones place digit.
result = result & IIf(result = "" Or Right(Amount, 2) = "00", "", " و") & ConvertDigit(Mid(Amount, 3))
End If
ConvertHundreds = Trim(result)
End Function
Private Function ConvertTens(ByVal MyTens)
Dim result As String
' Is value between 10 and 19?
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
' .. otherwise it's between 20 and 99.
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
' Convert ones place digit.
result = ConvertDigit(Right(MyTens, 1)) & IIf(Right(MyTens, 1) = 0, "", " و") & result
End If
ConvertTens = result
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
4Option Explicit
Function ConvertCurrencyToEnglish(ByVal Amount)
Dim Temp
Dim Derhams, Fils
Dim DecimalPlace, Count
Dim tmpAmount As Integer
ReDim Place(9) As String
Place(2) = " الاف"
Place(3) = " مليون"
Place(4) = " مليار"
Place(5) = " ترليون"
' Convert Amount to a string, trimming extra spaces.
Amount = Trim(Format(Amount, "#########"))
tmpAmount = CInt(Right(Amount, 2))
' Find decimal place.
DecimalPlace = InStr(Amount, ".")
' If we find decimal place...
If DecimalPlace > 0 Then
' Convert Fils
Temp = Left(Mid(Amount, DecimalPlace + 1) & "00", 2)
Fils = ConvertTens(Temp)
' Strip off Fils from remainder to convert.
Amount = Trim(Left(Amount, DecimalPlace - 1))
End If
Count = 1
Do While Amount <> ""
' Convert last 3 digits of Amount to English Derhams.
If Count < 2 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" Then Derhams = Temp & Place(Count) & Derhams
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 2 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "الف " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "الفا ", "الفان ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " الاف", " الفا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 3 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "مليون " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "مليونا ", "مليونان ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " ملايين", " مليونا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
ElseIf Count = 4 Then
Temp = ConvertHundreds(Right(Amount, 3))
If Temp <> "" And Right(Amount, 3) <> "" Then
If Right(Amount, 3) = "1" Then
Derhams = "مليار " & IIf(Derhams = "", "", "و") & Derhams
ElseIf Right(Amount, 3) = "2" Then
Derhams = IIf(Derhams = "", "مليارا ", "ملياران ") & IIf(Derhams = "", "", "و") & Derhams
Else
Derhams = Temp & IIf(CInt(Right(Amount, 3)) < 11, " مليارات", " مليارا") & IIf(Derhams = "", "", " و") & Derhams
End If
End If
If Len(Amount) > 3 Then
' Remove last 3 converted digits from Amount.
Amount = Left(Amount, Len(Amount) - 3)
Else
Amount = ""
End If
End If
Count = Count + 1
Loop
' Clean up Derhams.
Select Case Derhams
Case ""
Derhams = "صفر دينار"
Case "واحد"
Derhams = "دينار واحد"
Case "اثنان"
Derhams = "ديناران"
Case Else
Derhams = " " & Derhams & IIf(tmpAmount > 0 And tmpAmount < 11, " دنانير", " دينار")
End Select
Derhams = Derhams + " لا غير"
' Clean up Fils.
Select Case Fils
Case ""
Fils = " دينار, صفر فلس"
Case "One"
Fils = " And One Fils"
Case Else
Fils = " And " & Fils & " Fils"
End Select
ConvertCurrencyToEnglish = Derhams
End Function
Private Function ConvertHundreds(ByVal Amount)
Dim result As String
' Exit if there is nothing to convert.
If Val(Amount) = 0 Then Exit Function
' Append leading zeros to number.
Amount = Right("000" & Amount, 3)
' Do we have a hundreds place digit to convert?
If Left(Amount, 1) <> "0" Then
Select Case Left(Amount, 1)
Case 1: result = "مئة"
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
End If
' Do we have a tens place digit to convert?
If Mid(Amount, 2, 1) <> "0" Then
result = result & IIf(result = "" Or Right(Amount, 2) = "00", "", " و") & ConvertTens(Mid(Amount, 2))
Else
' If not, then convert the ones place digit.
result = result & IIf(result = "" Or Right(Amount, 2) = "00", "", " و") & ConvertDigit(Mid(Amount, 3))
End If
ConvertHundreds = Trim(result)
End Function
Private Function ConvertTens(ByVal MyTens)
Dim result As String
' Is value between 10 and 19?
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
' .. otherwise it's between 20 and 99.
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
' Convert ones place digit.
result = ConvertDigit(Right(MyTens, 1)) & IIf(Right(MyTens, 1) = 0, "", " و") & result
End If
ConvertTens = result
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
123456.254
مائة وثلاثة وعشرون الفا واربعمئة وست وخمسون دينارا ومئتان واربع وخمسون فلسا