Главная > Coding > Сумма прописью на VB

Сумма прописью на 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
  1. Пока что нет комментариев.
Подписаться на комментарии по RSS