|
|
Const SPACE As String = " " 'Определяет число пробелов между словами
'==============================================================
' Назначение:
' Перевод числа в строковую константу
' Параметры
' curMoney - сумма, которую надо перевести в строку
' flagBank - указывает какую сумму надо вернуть
' Пример:
' funRusMoney(678.56) = "Шестьсот семьдесят восемь рублей 56 копеек"
'
Public Function funRusMoney(curMoney As Currency, flagBank) As String
Dim myMoney As Currency 'Все деньги
Dim myRoubles As Long 'Только рубли
Dim myCopecks As Long 'Только копейки
Dim iGroup As Long 'Группировка по разрядам
Dim s As String 'Промежуточная переменная
On Error GoTo 999
'Проведем округление абслютного результата до 2х разрядов.
'Иногда бывает в функцию передается результат: -678,56001,
'а нам нужен 678,56
myMoney = Format(Abs(curMoney), "0.00")
'Проверка входящей суммы
If myMoney > 2147483647.99 Then
MsgBox "Очень большое число: " & Format(curMoney, "Currency") & vbCrLf & _
"Максимальное число: 2 147 483 647,99", vbExclamation, "Сумма прописью"
funRusMoney = "Слишком большое число: " & curMoney
Exit Function
End If
'Определяем рубли и копейки
myRoubles = CLng(Fix(myMoney))
myCopecks = (myMoney - Fix(myMoney)) * 100
If myRoubles <> 0 Then 'Есть рубли
'Миллиарды рублей
s = funTextMoney(myRoubles, myCopecks, 1000000000, "М", iGroup)
'Миллионы рублей
s = s & funTextMoney(myRoubles, myCopecks, 1000000, "М", iGroup)
'Тысячи рублей
s = s & funTextMoney(myRoubles, myCopecks, 1000, "Ж", iGroup)
'Cотни рублей
s = s & funTextMoney(myRoubles, myCopecks, 1, "М", iGroup)
'Дописываем рубли
s = s & strRoubles(iGroup)
Else 'Нет рублей
s = "0 рублей" & SPACE
End If
'Добавляем копейки прописью
If (flagBank = True) And (myCopecks = 0) Then
'не добавляем копеек по инструкции Центробанка
Else
s = s & strCopecks(myCopecks) 'Дописываем копейки
End If
'Вывод текста c Заглавной буквы
funRusMoney = UCase(Mid(s, 1, 1)) & Mid(s, 2)
Exit Function
999:
MsgBox Err.Description, vbCritical, "Сумма прописью"
funRusMoney = "Ошибка в прописи суммы: " & curMoney
Err.Clear
End Function
'==============================================================
' Назначение:
' Перевод для разных групп чисел в строковую константу
' Параметры
' myRoubles - рубли
' myCopecks - копейки
' iSize - размер группы (1, 1000, ...)
' sSex - пол группы (М - мужской, Ж - женский)
' Пример:
' funTextMoney(678,25,1,"М") = _
' "шестьсот семьдесят восемь рублей 25 копеек"
'
Public Function funTextMoney( _
myRoubles As Long, _
myCopecks As Long, _
iSize As Long, _
sSex As String, _
iGroup As Long _
) As String
Dim iBlock As Long 'Блок данных
Dim sOut As String 'Выходная строка
sOut = "" 'Инициализация переменной
iGroup = myRoubles \ iSize 'Возвращем число 0-999
If (iGroup <> 0) Then
iBlock = iGroup \ 100 'Вернуть сотни
sOut = sOut & strHundreds(iBlock) 'Вернуть текст
myRoubles = myRoubles - iBlock * 100 * iSize 'Оставшаяся сумма
iGroup = iGroup - iBlock * 100 'Возвращем число 0-99
If iGroup > 19 Then
iBlock = iGroup \ 10 'Вернуть десятки
sOut = sOut & strTens(iBlock) 'Вернуть текст
myRoubles = myRoubles - iBlock * 10 * iSize 'Оставшаяся сумма
iGroup = iGroup - iBlock * 10 'Возвращем число 0-9
End If
sOut = sOut & strOne(iGroup, sSex) 'Вернуть текст
myRoubles = myRoubles - iGroup * iSize 'Оставшаяся сумма
'Добавляем текст в конец строки
Select Case iSize
Case 1000000000: sOut = sOut & strBillions(iGroup)
Case 1000000: sOut = sOut & strMillions(iGroup)
Case 1000: sOut = sOut & strThousand(iGroup)
End Select
End If
'Возвращаем текст
funTextMoney = sOut
End Function
'==============================================================
' Назначение:
' вернуть миллиарды прописью
' Пример:
' strBillions(2) = "миллиард"
'
Function strBillions(iBlock As Long) As String
Select Case iBlock
Case 1: strBillions = "миллиард"
Case 2 To 4: strBillions = "милиарда"
Case Else: strBillions = "миллиардов"
End Select
strBillions = strBillions & SPACE
End Function
'==============================================================
' Назначение:
' вернуть миллионы прописью
' Пример:
' strMillions(2) = "миллиона"
'
Public Function strMillions(iBlock As Long) As String
Select Case iBlock
Case 1: strMillions = "миллион"
Case 2 To 4: strMillions = "миллиона"
Case Else: strMillions = "миллионов"
End Select
strMillions = strMillions & SPACE
End Function
'==============================================================
' Назначение:
' вернуть тысячи прописью
' Пример:
' strThousand(2) = "тысячи"
'
Public Function strThousand(iBlock As Long) As String
Select Case iBlock
Case 1: strThousand = "тысяча"
Case 2 To 4: strThousand = "тысячи"
Case Else: strThousand = "тысяч"
End Select
strThousand = strThousand & SPACE
End Function
'==============================================================
' Назначение:
' вернуть сотни прописью
' Пример:
' strHundreds(2)="двести"
'
Public Function strHundreds(iBlock As Long) As String
Select Case iBlock
Case 1: strHundreds = "сто"
Case 2: strHundreds = "двести"
Case 3: strHundreds = "триста"
Case 4: strHundreds = "четыреста"
Case 5: strHundreds = "пятьсот"
Case 6: strHundreds = "шестьсот"
Case 7: strHundreds = "семьсот"
Case 8: strHundreds = "восемьсот"
Case 9: strHundreds = "девятьсот"
End Select
If iBlock > 0 Then strHundreds = strHundreds & SPACE
End Function
'==============================================================
' Назначение:
' вернуть десятки прописью
' Пример:
' strTens(3) = "тридцать"
'
Public Function strTens(iBlock As Long) As String
Select Case iBlock
Case 2: strTens = "двадцать"
Case 3: strTens = "тридцать "
Case 4: strTens = "сорок"
Case 5: strTens = "пятьдесят"
Case 6: strTens = "шестьдесят"
Case 7: strTens = "семьдесят"
Case 8: strTens = "восемьдесят"
Case 9: strTens = "девяносто"
End Select
If iBlock > 0 Then strTens = strTens & SPACE
End Function
'==============================================================
' Назначение:
' вернуть единицы прописью
' Пример:
' strOne(2, "М")="два"
Public Function strOne(iBlock As Long, sSex As String) As String
Select Case iBlock
Case 1, 2
Select Case iBlock & sSex 'Определяем пол
Case "1М": strOne = "один" 'Мужской пол
Case "2М": strOne = "два" 'Мужской пол
Case "1Ж": strOne = "одна" 'Женский пол
Case "2Ж": strOne = "две" 'Женский пол
End Select
Case 3: strOne = "три"
Case 4: strOne = "четыре"
Case 5: strOne = "пять"
Case 6: strOne = "шесть"
Case 7: strOne = "семь"
Case 8: strOne = "восемь"
Case 9: strOne = "девять"
Case 10: strOne = "десять"
Case 11: strOne = "одиннадцать"
Case 12: strOne = "двенадцать"
Case 13: strOne = "тринадцать"
Case 14: strOne = "четырнадцать"
Case 15: strOne = "пятнадцать"
Case 16: strOne = "шестнадцать"
Case 17: strOne = "семнадцать"
Case 18: strOne = "восемнадцать"
Case 19: strOne = "девятнадцать"
End Select
If iBlock > 0 Then strOne = strOne & SPACE
End Function
'==============================================================
' Назначение:
' вернуть копейки прописью
' Пример:
' strCopecks(56) = "56 копеек"
'
Public Function strCopecks(myCopecks As Long) As String
Dim r As Integer 'разряд копеек
'Записываем копейки
strCopecks = Format(myCopecks, "00") & SPACE
'Определяем разряд копеек
r = myCopecks
If myCopecks > 20 Then r = r - Fix(r / 10) * 10
Select Case r 'Составляем текст
Case 1: strCopecks = strCopecks & "копейка"
Case 2 To 4: strCopecks = strCopecks & "копейки"
Case Else: strCopecks = strCopecks & "копеек"
End Select
End Function
'==============================================================
' Назначение:
' вернуть название рублей прописью
' Пример:
' strRoubles(2) = "рубля"
'
Public Function strRoubles(iBlock As Long) As String
Select Case iBlock
Case 1: strRoubles = "рубль"
Case 2 To 4: strRoubles = "рубля"
Case Else: strRoubles = "рублей"
End Select
strRoubles = strRoubles & SPACE
End Function
'==============================================================
' Назначение:
' вернуть сумму по инструкции центробанка
'
Public Function strConvBank(curMoney As Currency) As String
Dim myCopecks As Long
' strConvBank = Format(curMoney, "0") 'Формат рублей
myCopecks = (curMoney - Fix(curMoney)) * 100
strConvBank = CStr(curMoney - myCopecks / 100)
If myCopecks = 0 Then
strConvBank = strConvBank & "=" 'Без копеек
Else
strConvBank = strConvBank & "-" & Format(myCopecks, "00") 'С копейками
End If
End Function
|
|