Attribute VB_Name = "Float2String"
'В функцию можно передать число, чтобы она написала его по умолчанию в формате 5000 (Пять тысяч) рублей 05 копеек
'можно написать без скобок, без слова рубли и копейки, без самого числа цифрами
'Пятьдесят тысяч четыре =RUR2TEXT(n, FALSE, FALSE, FALSE)
'(Пятьдесят тысяч три) рубля 00 копеек =RUR2TEXT(n, TRUE, TRUE, FALSE)
'50002 (Пятьдесят тысяч два) =RUR2TEXT(n, TRUE, FALSE)
'50001 Пятьдесят тысяч один рубль 00 копеек =RUR2TEXT(n, FALSE)
'(число на распознавание, скобки, слово рублей и копеек, писать ли впереди цифрами само число)
Function RUR2TEXT(n As Variant, Optional ByVal skobki As Boolean = True, Optional ByVal withRUR = True, Optional ByVal withcifers = True) As String
Dim cifers_txt As String 'это переменная содержащая само число прописью, именно текст, без скобок или еще чего
Dim Nums1, Nums2, Nums3, Nums4 As Variant
Dim s_predfinal As String 'просто тестовая строка, которую будем немного форматировать
Nums1 = Array("", "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
Nums2 = Array("", "десять ", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", _
"восемьдесят ", "девяносто ")
Nums3 = Array("", "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", _
"восемьсот ", "девятьсот ")
Nums4 = Array("", "одна ", "две ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
Nums5 = Array("десять ", "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", _
"пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ")
If IsNull(n) Then n = 0 'если по какой то причине прислали нулл, то просто нулим
minusflag = n < 0
n = Abs(n) 'делаем модуль
n = Round(n, 2) 'округляем до разумного - копеек
If n >= 0 And n < 1 Then 'на случай ноль рублей
ed_txt = "Ноль"
GoTo final
End If
'разделяем число на разряды, используя вспомогательную функцию Class
ed = Class(n, 1)
dec = Class(n, 2)
sot = Class(n, 3)
tys = Class(n, 4)
dectys = Class(n, 5)
sottys = Class(n, 6)
mil = Class(n, 7)
decmil = Class(n, 8)
sotmil = Class(n, 9)
sotmil_txt = Nums3(sotmil) 'проверяем сотни миллионов
'проверяем десятки миллионов
Select Case decmil
Case 1
mil_txt = mil_txt & Nums5(mil) & "миллионов "
GoTo www
Case 2 To 9
decmil_txt = Nums2(decmil)
End Select
Select Case mil
Case 0
If decmil > 0 Then mil_txt = Nums4(mil) & "миллионов "
Case 1
mil_txt = Nums1(mil) & "миллион "
Case 2, 3, 4
mil_txt = Nums1(mil) & "миллиона "
Case 5 To 20
mil_txt = Nums1(mil) & "миллионов "
End Select
If decmil = 0 And mil = 0 And sotmil <> 0 Then sotmil_txt = sotmil_txt & "миллионов"
www:
sottys_txt = Nums3(sottys) 'сотни тысяч
'проверяем тысячи
Select Case dectys
Case 1
tys_txt = Nums5(tys) & "тысяч "
GoTo eee
Case 2 To 9
dectys_txt = Nums2(dectys)
End Select
Select Case tys
Case 0
If dectys > 0 Then tys_txt = Nums4(tys) & "тысяч "
Case 1
tys_txt = Nums4(tys) & "тысяча "
Case 2, 3, 4
tys_txt = Nums4(tys) & "тысячи "
Case 5 To 9
tys_txt = Nums4(tys) & "тысяч "
End Select
If dectys = 0 And tys = 0 And sottys <> 0 Then sottys_txt = sottys_txt & " тысяч "
eee:
sot_txt = Nums3(sot)
'проверяем десятки
Select Case dec
Case 1
ed_txt = Nums5(ed)
GoTo rrr
Case 2 To 9
dec_txt = Nums2(dec)
End Select
ed_txt = Nums1(ed)
rrr:
'формируем итоговую строку
final:
'если нам надлежит присобачивать туда рубли и копейки
If withRUR Then
'далее речь о копейках (нелогично да, потом о рублях поговорим)
Dim kop_str As String, kop_int, kop_ed, kop_dec As Integer 'надо правильно создать копейки
kop_int = (Round((n - Fix(n)) * 100))
kop_ed = Class(kop_int, 1)
kop_dec = Class(kop_int, 2)
kop_str = CStr(kop_int) 'тут особо не требуется словесных наименований цифр, копейки пишем просто числом
If kop_int < 10 Then kop_str = "0" & kop_str 'если меньше 10 копеек то надо добавить нолик
Select Case kop_dec 'проверяем десятки копеек
Case 1
kop_str = kop_str & " копеек" 'от 10 до 19 все числа идут с окончаниеем копеек
Case Else 'а в диапазоне 0-9 и 20-99 применимо правило последней цифры
Select Case kop_ed
Case 0 'ноль копеек, двадцать копеек, тридцать копеек
kop_str = kop_str & " копеек"
Case 1 'одна копейка
kop_str = kop_str & " копейка"
Case 2, 3, 4 'две три и четыре копейки
kop_str = kop_str & " копейки"
Case 5 To 9 '5, 6 , 9 копеек
kop_str = kop_str & " копеек"
End Select
End Select
'теперь о рублях
Dim rur_str As String
Select Case dec 'проверяем десятки рублей
Case 1
rur_str = rur_str & "рублей" 'от 10 до 19 все числа идут с окончаниеем рублей
Case Else 'а в диапазоне 0-9 и 20-99 применимо правило последней цифры
Select Case ed 'кейсуем последнюю цифру единиц чтобы определиться с окончанием
Case 0 'ноль копеек, двадцать копеек, тридцать копеек
rur_str = rur_str & "рублей"
Case 1 'одна копейка
rur_str = rur_str & "рубль"
Case 2, 3, 4 'две три и четыре копейки
rur_str = rur_str & "рубля"
Case 5 To 9 '5, 6 , 9 копеек
rur_str = rur_str & "рублей"
End Select
End Select
Else
rur_str = ""
kop_str = ""
End If 'если надлежит присобачивать рубли и копейки закончилось
'а теперь по условиям набираем предфинальную строку
If minusflag Then cifers_txt = "Минус "
cifers_txt = cifers_txt & sotmil_txt & decmil_txt & mil_txt & sottys_txt & dectys_txt & tys_txt & sot_txt & dec_txt & ed_txt
cifers_txt = Replace(cifers_txt, Left(cifers_txt, 1), UCase(Left(cifers_txt, 1)), 1, 1) 'поднимаем регистр первого символа для красоты написания
cifers_txt = Trim(cifers_txt) 'чистим краевые пробелы
If minusflag Then n = -n 'не забываем вернуть числу минус, который мы отбирали у него ради вычислений
If withcifers Then s_predfinal = s_predfinal & CStr(Fix(n)) 'если нужно печатать в ее начале сами цифры
If skobki Then
s_predfinal = s_predfinal & " (" & cifers_txt & ")" 'если нам нужны скобки
Else
s_predfinal = s_predfinal & " " & cifers_txt
End If
If withRUR Then s_predfinal = s_predfinal & " " & rur_str & " " & kop_str 'если нам нужны обозначения рубля и копеек
s_predfinal = Replace(s_predfinal, " ", " ") 'удаляем двойные пробелы
s_predfinal = Trim(s_predfinal) 'удаляем краевые пробелы
s_predfinal = Replace(s_predfinal, " )", ")") 'убираем пробел перед второй скобкой
RUR2TEXT = s_predfinal
End Function
'вспомогательная функция для выделения из числа разрядов
Private Function Class(M, I)
Class = Int(Int(M - (10 ^ I) * Int(M / (10 ^ I))) / 10 ^ (I - 1))
End Function
|