|
ضع في Report Custom Functions
يظهر
Function NumberToText(Amount As Double, MainCurrency As String, SubCurrency As String)
Dim Array1(10) As String
Dim Array2(10) As String
Dim Array3(10) As String
Dim MyNumber As String
Dim GetNumber As String
Dim ReadNumber As Number
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetText As String
Dim Billion As String
Dim Million As String
Dim Thousand As String
Dim Hundred As String
Dim Fraction As String
Dim MyAnd As String
Dim I As Number
Dim ReMark As String
If Amount > 999999999999.99 Then
Exit Function
End If
If Amount < 0 Then
Amount = Amount * -1
ReMark = "سالب "
End If
If Amount = 0 Then
NumberToText = "صفر"
Exit Function
End If
MyAnd = " و"
Array1(1) = ""
Array1(2) = "مائة"
Array1(3) = "مائتان"
Array1(4) = "ثلاثمائة"
Array1(5) = "أربعمائة"
Array1(6) = "خمسمائة"
Array1(7) = "ستمائة"
Array1(8) = "سبعمائة"
Array1(9) = "ثمانمائة"
Array1(10) = "تسعمائة"
Array2(1) = ""
Array2(2) = " عشر"
Array2(3) = "عشرون"
Array2(4) = "ثلاثون"
Array2(5) = "أربعون"
Array2(6) = "خمسون"
Array2(7) = "ستون"
Array2(8) = "سبعون"
Array2(9) = "ثمانون"
Array2(10) = "تسعون"
Array3(1) = ""
Array3(2) = "واحد"
Array3(3) = "اثنان"
Array3(4) = "ثلاثة"
Array3(5) = "أربعة"
Array3(6) = "خمسة"
Array3(7) = "ستة"
Array3(8) = "سبعة"
Array3(9) = "ثمانية"
Array3(10) = "تسعة"
GetNumber = ToText(Amount, "000000000000.00")
I = 0
Do While I < 15
If I < 12 Then
MyNumber = Mid(GetNumber, I + 1, 3)
Else
MyNumber = "0" + Mid(GetNumber, I + 2, 2)
End If
If ToNumber(Mid(MyNumber, 1, 3)) > 0 Then
ReadNumber = ToNumber(Mid(MyNumber, 1, 1))
My100 = Array1(ReadNumber+1)
ReadNumber = ToNumber(Mid(MyNumber, 3, 1))
My1 = Array3(ReadNumber+1)
ReadNumber = ToNumber(Mid(MyNumber, 2, 1))
My10 = Array2(ReadNumber+1)
If Mid(MyNumber, 2, 2) = "11" Then
My11 = "إحدى عشرة"
End If
If Mid(MyNumber, 2, 2) = "12" Then
My12 = "إثنى عشرة"
End If
If Mid(MyNumber, 2, 2) = "10" Then
My10 = "عشرة"
End If
If (ToNumber((Mid(MyNumber, 1, 1))) > 0) And (ToNumber((Mid(MyNumber, 2, 2))) > 0) Then
My100 = My100 + MyAnd
End If
If (ToNumber(Mid(MyNumber, 3, 1)) > 0) And (ToNumber(Mid(MyNumber, 2, 1)) > 1) Then
My1 = My1 + MyAnd
End If
GetText = My100 + My1 + My10
If (ToNumber(Mid(MyNumber, 3, 1)) = 1) And (ToNumber(Mid(MyNumber, 2, 1)) = 1) Then
GetText = My100 + My11
If (ToNumber(Mid(MyNumber, 1, 1)) = 0) Then
GetText = My11
End If
End If
If (ToNumber(Mid(MyNumber, 3, 1)) = 2) And (ToNumber(Mid(MyNumber, 2, 1)) = 1) Then
GetText = My100 + My12
If (ToNumber(Mid(MyNumber, 1, 1)) = 0) Then
GetText = My12
End If
End If
If (I = 0) And (GetText <> "") Then
If (ToNumber(Mid(MyNumber, 1, 3)) > 10) Then
Billion = GetText + " مليار"
Else
Billion = GetText + " مليارات"
If (ToNumber(Mid(MyNumber, 1, 3)) = 2) Then
Billion = " مليار"
End If
If (ToNumber(Mid(MyNumber, 1, 3)) = 2) Then
Billion = " مليارن"
End If
End If
End If
If (I = 3) And (GetText <> "") Then
If (ToNumber(Mid(MyNumber, 1, 3)) > 10) Then
Million = GetText + " مليون"
Else
Million = GetText + " ملايين"
If (ToNumber(Mid(MyNumber, 1, 3)) = 1) Then
Million = " مليون"
End If
If (ToNumber(Mid(MyNumber, 1, 3)) = 2) Then
Million = " مليونان"
End If
End If
End If
If (I = 6) And (GetText <> "") Then
If (ToNumber(Mid(MyNumber, 1, 3)) > 10) Then
Thousand = GetText + " ألف"
Else
Thousand = GetText + " ألاف"
If (ToNumber(Mid(MyNumber, 3, 1)) = 1) Then
Thousand = " ألف"
End If
If (ToNumber(Mid(MyNumber, 3, 1)) = 2) Then
Thousand = " ألفان"
End If
End If
End If
If (I = 9) And (GetText <> "") Then
Hundred = GetText
End If
If (I = 12) And (GetText <> "") Then
Fraction = GetText
End If
End If
I = I + 3
Loop
If (Billion <> "") Then
If (Million <> "") Or (Thousand <> "") Or (Hundred <> "") Then
Billion = Billion + MyAnd
End If
End If
If (Million <> "") Then
If (Thousand <> "") Or (Hundred <> "") Then
Million = Million + MyAnd
End If
End If
If (Thousand <> "") Then
If (Hundred <> "") Then
Thousand = Thousand + MyAnd
End If
End If
If Fraction <> "" Then
If (Billion <> "") Or (Million <> "") Or (Thousand <> "") Or (Hundred <> "") Then
NumberToText = ReMark + Billion + Million + Thousand + Hundred + " " + MainCurrency + MyAnd + Fraction + " " + SubCurrency
Else
NumberToText = ReMark + Fraction + " " + SubCurrency
End If
Else
NumberToText = ReMark + Billion + Million + Thousand + Hundred + " " + MainCurrency
End If
End Function
ثم استعملها هكذا
NumberToText (5431.24 ,"جنيه","قرش")
شكرا
|
|
|
|