TopPicLogo TopPicText

Сумма Прописью

Давно пользуюсь - "мин" нет.

'--------------------------------------------------------------------------
' Module    : modSumProp
' Author    : Коллектив ()
' Date      : Прибл. 1996 - 1998
' Purpose   : Формирование Суммы прописью (Типа: "Двадцать пять рублей 33 копейки.")
'           : При аргумете bInWeight = True - вернёт килограммы и граммы (Типа: "Двадцать пять кг. 33 гр.")
'--------------------------------------------------------------------------
' Посл. Редакция: es 09.12.2016
'-----------------------------------------------------------------------------

Option Compare Database   'Использовать порядок сортировки базы данных
Option Explicit           'Вкл. обязательного объявления переменных

Private Skl As Byte
Public Function StrSum(n As Currency, Optional rub As Boolean = True, Optional bInWeight As Boolean = False) As String
'Аргументы:
'   n          = сумма в формате Currency
'   rub        = false - без копеек, true - полностью (по умолчанию)
'   bInWeight  = false (по умолчанию) - сумма прописью, true - Возвращаем: килограммы и граммы
'-----------------------------------------------------------------------------
'Назначение: Конвертирует сумму в сумму прописью (или в килограммы и граммы)
'Возвращает: Сумму прописью ("Двадцать пять рублей 33 копейки." или "Двадцать пять кг. 330 гр.")
'-----------------------------------------------------------------------------
Dim s$, R$, K$
Dim t%, u%, v%, w%
    
    If bInWeight = True Then rub = False 'Для возврата в килограммах и граммах: Агумент rub должен быть = False!
        
    s = ""

    If n < 0 Then
        n = Abs(n)
        s = "минус"
    End If
'-----------------------------------------------------------------------------
    v = (n - Fix(n)) * 100 ' Число копеек
    If bInWeight = True Then
        v = (n - Fix(n)) * 1000 ' Число копеек
    
    End If
    w = val(Right(Format(v), 1)) ' Получить число единиц копеек

    n = Fix(n) ' Целое число рублей
    t = val(Right(Format(n), 2)) ' Получить две последние цифры рублей
    u = val(Right(t, 1)) ' Получить число единиц рублей
    
    If t > 10 And t < 15 Then
        R = " рублей" ' Получить подпись для рублей
    ElseIf u = 1 Then
        R = " рубль"
    ElseIf u > 1 And u < 5 Then
        R = " рубля"
    Else
        R = " рублей"
    End If

    If v > 10 And v < 15 Then
        K = " копеек." ' Получить подпись для копеек
    ElseIf w = 1 Then
        K = " копейка."
    ElseIf w > 1 And w < 5 Then
        K = " копейки."
    Else
        K = " копеек."
    End If

'-----------------------------------------------------------------------------
    If n > 1000000000000# Then
        s = AddStr(s, StrSum2(Int(n / 1000000000000#), True))
        
        Select Case Skl
            Case 0:    s = AddStr(s, "триллион")
            Case 1:    s = AddStr(s, "триллиона")
            Case 2:    s = AddStr(s, "триллионов")
        End Select
        
        n = n - Int(n / 1000000000000#) * 1000000000000#
    End If

    If n > 1000000000 Then
        s = AddStr(s, StrSum2(Int(n / 1000000000), True))
        Select Case Skl
            Case 0:    s = AddStr(s, "миллиард")
            Case 1:    s = AddStr(s, "миллиарда")
            Case 2:    s = AddStr(s, "миллиардов")
        End Select
        n = n - Int(n / 1000000000) * 1000000000
    End If

    If n > 1000000 Then
        s = AddStr(s, StrSum2(n \ 1000000, True))
        Select Case Skl
            Case 0:    s = AddStr(s, "миллион")
            Case 1:    s = AddStr(s, "миллиона")
            Case 2:    s = AddStr(s, "миллионов")
        End Select
        n = n Mod 1000000
    End If

    If n > 1000 Then
        s = AddStr(s, StrSum2(n \ 1000, False))
        Select Case Skl
            Case 0:    s = AddStr(s, "тысяча")
            Case 1:    s = AddStr(s, "тысячи")
            Case 2:    s = AddStr(s, "тысяч")
        End Select
        n = n Mod 1000
    End If

    If n > 0 Then
        s = AddStr(s, StrSum2(n, True))
    End If

    If s = "" Then
        s = "ноль"
    ElseIf s = "минус" Then
        s = s + " ноль"
    End If

    StrSum = StrConv(Mid(s, 1, 1), vbUpperCase) + Mid(s, 2, Len(s) - 1)
    If (rub) Then
        StrSum = StrSum & R & Format(v, " 00") & K
    Else
        If bInWeight = True Then
            StrSum = StrSum & " кг." & Format(v, " 000") & " гр."
        End If
    End If

End Function
'-----------------------------------------------------------------------------

Private Function StrSum2(n As Currency, male As Boolean) As String
Dim s As String
    s = ""
    If n >= 100 Then
        s = StrSum1(((n \ 100) * 100), male)
        n = n Mod 100
    End If
    
    If n >= 20 Then
        s = AddStr(s, StrSum1(((n \ 10) * 10), male))
        n = n Mod 10
    End If
    StrSum2 = AddStr(s, StrSum1(n, male))

End Function
'-----------------------------------------------------------------------------

Private Function StrSum1(n As Currency, male As Boolean) As String
    Skl = 2
    Select Case n
        Case 100:        StrSum1 = "сто"
        Case 200:        StrSum1 = "двести"
        Case 300:        StrSum1 = "триста"
        Case 400:        StrSum1 = "четыреста"
        Case 500:        StrSum1 = "пятьсот"
        Case 600:        StrSum1 = "шестьсот"
        Case 700:        StrSum1 = "семьсот"
        Case 800:        StrSum1 = "восемьсот"
        Case 900:        StrSum1 = "девятьсот"
        Case 11:        StrSum1 = "одиннадцать"
        Case 12:        StrSum1 = "двенадцать"
        Case 13:        StrSum1 = "тринадцать"
        Case 14:        StrSum1 = "четырнадцать"
        Case 15:        StrSum1 = "пятнадцать"
        Case 16:        StrSum1 = "шестнадцать"
        Case 17:        StrSum1 = "семнадцать"
        Case 18:        StrSum1 = "восемнадцать"
        Case 19:        StrSum1 = "девятнадцать"
        Case 20:        StrSum1 = "двадцать"
        Case 30:        StrSum1 = "тридцать"
        Case 40:        StrSum1 = "сорок"
        Case 50:        StrSum1 = "пятьдесят"
        Case 60:        StrSum1 = "шестьдесят"
        Case 70:        StrSum1 = "семьдесят"
        Case 80:        StrSum1 = "восемьдесят"
        Case 90:        StrSum1 = "девяносто"
        Case 1
            Skl = 0
            If male Then
                StrSum1 = "один"
            Else
                StrSum1 = "одна"
            End If
        Case 2
            Skl = 1
            If male Then
                StrSum1 = "два"
            Else
                StrSum1 = "две"
            End If
        Case 3: Skl = 1: StrSum1 = "три"
        Case 4: Skl = 1: StrSum1 = "четыре"
        Case 5:        StrSum1 = "пять"
        Case 6:        StrSum1 = "шесть"
        Case 7:        StrSum1 = "семь"
        Case 8:        StrSum1 = "восемь"
        Case 9:        StrSum1 = "девять"
        Case 10:       StrSum1 = "десять"
    End Select
End Function
'-----------------------------------------------------------------------------

Private Function AddStr(S1 As String, S2 As String)
    If S1 = "" Then
        AddStr = S2
    ElseIf S2 = "" Then
        AddStr = S1
    Else
        AddStr = S1 + " " + S2
    End If
End Function



Назад ToTop
L.E. 09.12.2016
Рейтинг@Mail.ru