Сумма прописью на VB
Недавно натолкнулся на задачу перевода числа в строку с прописным аналогом на Visual Basic, например 264,32 в «двести шестьдесят четыре тридцать два».Я думал, гугл захлебнется выдачей, ан нет, пришлось порядочно повозиться. Затем я подумал, что вот такие вещи, на которое тратишь много времени, можно опубликовывать в виде небольших постов, и ждать улов. Будем оформлять такие посты в виде заметок в стиле Nota Bene (лат. — примите к сведению)
Код конечно не претендует на Оскара, но он рабочий.
Const SPACECHAR = " " 'Определяет число пробелов между словами '============================================================== ' Назначение: ' Перевод числа в строковую константу ' Параметры ' curMoney - сумма, которую надо перевести в строку ' flagBank - указывает какую сумму надо вернуть ' Пример: ' funRusMoney(678.56) = "Шестьсот семьдесят восемь рублей 56 копеек" ' Function funRusMoney(curMoney, flagBank) Dim myMoney 'Все деньги Dim myRoubles 'Только рубли Dim myCopecks 'Только копейки Dim iGroup 'Группировка по разрядам Dim s 'Промежуточная переменная On Error GoTo 0 'Проведем округление абслютного результата до 2х разрядов. 'Иногда бывает в функцию передается результат: -678,56001, 'а нам нужен 678,56 '-myMoney = Format(Abs(curMoney), "0.00") myMoney = FormatNumber(Abs(curMoney), 2) 'Проверка входящей суммы If myMoney > 2147483647.99 Then AppendToLog "Очень большое число: " & 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 рублей" & SPACECHAR 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 AppendToLog Err.Description, vbCritical, "Сумма прописью" funRusMoney = "Ошибка в прописи суммы: " & curMoney Err.Clear End Function '============================================================== ' Назначение: ' Перевод для разных групп чисел в строковую константу ' Параметры ' myRoubles - рубли ' myCopecks - копейки ' iSize - размер группы (1, 1000, ...) ' sSex - пол группы (М - мужской, Ж - женский) ' Пример: ' funTextMoney(678,25,1,"М") = _ ' "шестьсот семьдесят восемь рублей 25 копеек" ' Function funTextMoney( _ myRoubles, _ myCopecks, _ iSize , _ sSex , _ iGroup _ ) Dim iBlock 'Блок данных Dim sOut 'Выходная строка 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 ) Select Case iBlock Case 1: strBillions = "миллиард" Case 2, 3, 4: strBillions = "милиарда" Case Else: strBillions = "миллиардов" End Select strBillions = strBillions & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть миллионы прописью ' Пример: ' strMillions(2) = "миллиона" ' Function strMillions(iBlock ) Select Case iBlock Case 1: strMillions = "миллион" Case 2, 3, 4: strMillions = "миллиона" Case Else: strMillions = "миллионов" End Select strMillions = strMillions & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть тысячи прописью ' Пример: ' strThousand(2) = "тысячи" ' Function strThousand(iBlock ) Select Case iBlock Case 1: strThousand = "тысяча" Case 2, 3, 4: strThousand = "тысячи" Case Else: strThousand = "тысяч" End Select strThousand = strThousand & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть сотни прописью ' Пример: ' strHundreds(2)="двести" ' Function strHundreds(iBlock) 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 & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть десятки прописью ' Пример: ' strTens(3) = "тридцать" ' Function strTens(iBlock ) 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 & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть единицы прописью ' Пример: ' strOne(2, "М")="два" Function strOne(iBlock , sSex ) 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 & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть копейки прописью ' Пример: ' strCopecks(56) = "56 копеек" ' Function strCopecks(myCopecks ) Dim r 'разряд копеек 'Записываем копейки strCopecks = FormatNumber(myCopecks, 0) & SPACECHAR 'strCopecks = Format(myCopecks, "00") & SPACECHAR 'Определяем разряд копеек r = myCopecks If myCopecks > 20 Then r = r - Fix(r / 10) * 10 Select Case r 'Составляем текст Case 1: strCopecks = strCopecks & "копейка" Case 2, 3, 4: strCopecks = strCopecks & "копейки" Case Else: strCopecks = strCopecks & "копеек" End Select End Function '============================================================== ' Назначение: ' вернуть название рублей прописью ' Пример: ' strRoubles(2) = "рубля" ' Function strRoubles(iBlock ) Select Case iBlock Case 1: strRoubles = "рубль" Case 2, 3, 4: strRoubles = "рубля" Case Else: strRoubles = "рублей" End Select strRoubles = strRoubles & SPACECHAR End Function '============================================================== ' Назначение: ' вернуть сумму по инструкции центробанка ' Function strConvBank(curMoney ) Dim myCopecks ' 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