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

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\15 Формы\la_form1.mdb
 Язык интерфейса: Русский

   

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 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 = TrueAnd (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 LongAs String
    Select Case iBlock
        Case 1:      strBillions = "миллиард"
        Case To 4: strBillions = "милиарда"
        Case Else:   strBillions = "миллиардов"
    End Select
    strBillions = strBillions & SPACE
End Function


'==============================================================
' Назначение:
'       вернуть миллионы прописью
' Пример:
'       strMillions(2) = "миллиона"
'
Public Function strMillions(iBlock As LongAs String
    Select Case iBlock
        Case 1:      strMillions = "миллион"
        Case To 4: strMillions = "миллиона"
        Case Else:   strMillions = "миллионов"
    End Select
    strMillions = strMillions & SPACE
End Function


'==============================================================
' Назначение:
'       вернуть тысячи прописью
' Пример:
'       strThousand(2) = "тысячи"
'
Public Function strThousand(iBlock As LongAs String
    Select Case iBlock
        Case 1:      strThousand = "тысяча"
        Case To 4: strThousand = "тысячи"
        Case Else:   strThousand = "тысяч"
    End Select
    strThousand = strThousand & SPACE
End Function


'==============================================================
' Назначение:
'       вернуть сотни прописью
' Пример:
'       strHundreds(2)="двести"
'
Public Function strHundreds(iBlock As LongAs 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 LongAs 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 StringAs 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 LongAs String
Dim As Integer 'разряд копеек
    'Записываем копейки
    strCopecks = Format(myCopecks, "00") & SPACE
    
    'Определяем разряд копеек
    r = myCopecks
    If myCopecks > 20 Then r = r - Fix(r / 10) * 10
    Select Case 'Составляем текст
        Case 1:      strCopecks = strCopecks & "копейка"
        Case To 4: strCopecks = strCopecks & "копейки"
        Case Else:   strCopecks = strCopecks & "копеек"
    End Select
End Function


'==============================================================
' Назначение:
'       вернуть название рублей прописью
' Пример:
'       strRoubles(2) = "рубля"
'
Public Function strRoubles(iBlock As LongAs String
    Select Case iBlock
        Case 1:      strRoubles = "рубль"
        Case 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



Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access