Function ЧислоПрописью(число As Double) As String
' Ограничиваем квадриллионами
If число >= 1E+18 Then
ЧислоПрописью = "ОШИБКА: Слишком большое число"
Exit Function
End If
Dim numWords As String
numWords = ""
' Определение знака числа
If число = 0 Then
ЧислоПрописью = "ноль"
Exit Function
ElseIf число < 0 Then
numWords = "минус "
число = число * -1
End If
If число < 1 Then numWords = numWords & "ноль "
Dim arrN(1) As String, strNum As String
'==================================================================
' Разделение числа на целую и дробную части
strNum = Format(число, "000000000000000000.######")
Dim i As Integer
i = InStr(1, strNum, ",") + InStr(1, strNum, ".")
arrN(0) = Mid(strNum, 1, i - 1)
arrN(1) = Mid(strNum, i + 1)
strNum = ""
'==================================================================
' Разделение частей на разряды
Dim digs(0 To 7, 1 To 5) As String ' массив разрядов: _
1 столбец - число в виде строки _
2 - 4 столбецы - название разряда _
5 столбец - женский род для рязряда
Select Case Len(arrN(1))
Case 6
digs(0, 1) = Right(arrN(1), 3) ' млн. доли
digs(1, 1) = Left(arrN(1), 3) ' тыс. доли
digs(0, 2) = "миллионная"
digs(0, 3) = "миллионных"
digs(0, 4) = "миллионных"
digs(0, 5) = "1"
Case 5
digs(0, 1) = Right(arrN(1), 3) ' стотыс. доли
digs(1, 1) = "0" & Left(arrN(1), 2) ' сотые доли
digs(0, 2) = "стотысячная"
digs(0, 3) = "стотысячных"
digs(0, 4) = "стотысячных"
digs(0, 5) = "1"
Case 4
digs(0, 1) = Right(arrN(1), 3) ' десятитыс. доли
digs(1, 1) = "00" & Left(arrN(1), 1) ' десятые
digs(0, 2) = "десятитысячная"
digs(0, 3) = "десятитысячных"
digs(0, 4) = "десятитысячных"
digs(0, 5) = "1"
Case 3
digs(0, 1) = arrN(1) ' тыс. доли
digs(0, 2) = "тысячная"
digs(0, 3) = "тысячных"
digs(0, 4) = "тысячных"
digs(0, 5) = "1"
Case 2
digs(0, 1) = "0" & arrN(1) ' сотые доли
digs(0, 2) = "сотая"
digs(0, 3) = "сотых"
digs(0, 4) = "сотых"
digs(0, 5) = "1"
Case 1
digs(0, 1) = "00" & arrN(1) ' десятые доли
digs(0, 2) = "десятая"
digs(0, 3) = "десятых"
digs(0, 4) = "десятых"
digs(0, 5) = "1"
End Select
digs(2, 1) = Right(arrN(0), 3) ' до тысячи (не вкл.)
digs(3, 1) = Left(Right(arrN(0), 6), 3) ' тысячи
digs(4, 1) = Left(Right(arrN(0), 9), 3) ' млн
digs(5, 1) = Left(Right(arrN(0), 12), 3) ' млрд
digs(6, 1) = Left(Right(arrN(0), 15), 3) ' трлн
digs(7, 1) = Left(Right(arrN(0), 18), 3) ' квадрлн
'________
If Len(arrN(1)) > 0 Then
digs(1, 2) = "тысяча "
digs(1, 3) = "тысячи "
digs(1, 4) = "тысяч "
digs(1, 5) = "1"
digs(2, 2) = "целая "
digs(2, 3) = "целых "
digs(2, 4) = "целых "
digs(2, 5) = "1"
End If
digs(3, 2) = "тысяча "
digs(3, 3) = "тысячи "
digs(3, 4) = "тысяч "
digs(3, 5) = "1"
digs(4, 2) = "миллион "
digs(4, 3) = "миллиона "
digs(4, 4) = "миллионов "
digs(5, 2) = "миллиард "
digs(5, 3) = "миллиарда "
digs(5, 4) = "миллиардов "
digs(6, 2) = "триллион "
digs(6, 3) = "триллиона "
digs(6, 4) = "триллионов "
digs(7, 2) = "квадриллион "
digs(7, 3) = "квадриллиона "
digs(7, 4) = "квадриллионов "
Erase arrN
'==================================================================
' Перевод разрядов в текст
Dim N As Byte, tx As String
For i = 7 To 0 Step -1
If digs(i, 1) = "" Then GoTo NextFor
N = CByte(Left(digs(i, 1), 1))
Select Case N
Case 9: tx = "девятьсот "
Case 8: tx = "восемьсот "
Case 7: tx = "семьсот "
Case 6: tx = "шестьсот "
Case 5: tx = "пятьсот "
Case 4: tx = "четыреста "
Case 3: tx = "триста "
Case 2: tx = "двести "
Case 1: tx = "сто "
Case Else: tx = ""
End Select
N = CByte(Right(digs(i, 1), 2))
Select Case N
Case 10: tx = tx & "десять ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 11: tx = tx & "одиннадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 12: tx = tx & "двенадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 13: tx = tx & "тринадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 14: tx = tx & "четырнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 15: tx = tx & "пятнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 16: tx = tx & "шестнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 17: tx = tx & "семнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 18: tx = tx & "восемнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case 19: tx = tx & "девятнадцать ": digs(i, 1) = Left(digs(i, 1), 2) & "0"
Case Is >= 90: tx = tx & "девяносто "
Case Is >= 80: tx = tx & "восемьдесят "
Case Is >= 70: tx = tx & "семьдесят "
Case Is >= 60: tx = tx & "шестьдесят "
Case Is >= 50: tx = tx & "пятьдесят "
Case Is >= 40: tx = tx & "сорок "
Case Is >= 30: tx = tx & "тридцать "
Case Is >= 20: tx = tx & "двадцать "
End Select
N = CByte(Right(digs(i, 1), 1))
Select Case N
Case 1:
If digs(i, 5) = "" Then tx = tx & "один " Else tx = tx & "одна "
digs(i, 4) = digs(i, 2)
Case 2:
If digs(i, 5) = "" Then tx = tx & "два " Else tx = tx & "две "
digs(i, 4) = digs(i, 3)
Case 3:
tx = tx & "три "
digs(i, 4) = digs(i, 3)
Case 4:
tx = tx & "четыре "
digs(i, 4) = digs(i, 3)
Case 5: tx = tx & "пять "
Case 6: tx = tx & "шесть "
Case 7: tx = tx & "семь "
Case 8: tx = tx & "восемь "
Case 9: tx = tx & "девять "
End Select
numWords = numWords & IIf(tx = "" And i <> 2, "", tx & digs(i, 4))
NextFor:
Next i
N = Empty: tx = "": Erase digs
' Вывод результата
ЧислоПрописью = numWords
End Function
|