Программирование на Visual Basic

16. Этот код очень часто используется при разработке бухгалтерских систем, где требуется не только написать сумму, но и вывести ее прописью. Инструкция центробанка требует еще и разделение цифр не точкой, а дефисом -.

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