Сумма Прописью по Дмитрию Милосердову (универсальная)

Автор:  Дмитрий Милосердов  dimonm@yahoo.com  

       Универсальная функция суммы прописью с учетом 5-и знаков после запятой. Понимает женский, средний и мужской род.

Option Compare Database
Option Explicit
'===========================================================================
'АВТОР: Дмитрий Милосердов mailto:dimonm@yahoo.com
'
'Вы можете свободно использовать его в своих программах если сочтете полезным.
'Всякие гарантии по поводу его работоспособности и возможные последствия
'работы модуля автор с себя снимает (хотя таковых не должно быть).
'=============================================================================
'УНИВЕРСАЛЬНАЯ ФУНКЦИЯ ВЫВОДА ЧИСЛА (включающая в себя также дробные числа) ПРОПИСЬЮ
'на русском языке
'=============================================================================
Public Function SummaPropis(Num As Variant, String1 As String, String234 As String, StringOther As String, StringChego As String, sPol As String, Optional sPadezh As String, Optional sImen As String, Optional sRodit As String, Optional sDatel As String, Optional sVinit As String, Optional sTvorit As String, Optional sPredl As String) As String
'ВХОДНЫЕ ПАРАМЕТРЫ -
'NUM - число, для вывода прописью
'максимальное число 999 999 999 999 999,99999 (999 триллионов)
'анализируются только 5 знаков после запятой (стотысячная) ибо для
'финансовых расчетов в полне хватает 4 знаков (Currency), максимум до 5

'String1 - "одна что? - штука"
'Strin234 - "две, три, четыре чего? - штуки"
'StringOther - "пять, шесть, семь, 100, 355, и т.д чего? - штук"
'StringChego - "одна десятая чего? - штуки"
'sPol - "пол штуки какой? - женский ("ж")" - может быть "м","ж","с" (средний)
'ОСТАЛЬНЫЕ ПАРАМЕТРЫ ОПЦИОНАЛЬНЫ И ПОКА НЕ РЕАЛИЗОВАНЫ
'ЗАРЕЗЕРВИРОВАНЫ ДЛЯ ДАЛЬНЕЙШЕГО РАЗВИТИЯ (анализ падежей)
'на выходе строчка с текстовым представлением числа (прописью)
'Примеры использования в конце модуля
Dim Hundreds As Integer
Dim Thousands As Integer
Dim Millions As Integer
Dim Milliards As Integer
Dim Trillions As Integer
Dim lDlina As Long

Dim lCel As Variant
Dim sCel As String
Dim lDec As Variant
Dim sDec As String

If IsNull(Num) Then
SummaPropis = ""
Exit Function
End If

If Num = 0 Then
SummaPropis = ""
Exit Function
End If
If Num < 0 Then SummaPropis = "минус "
Num = Abs(Num)
lCel = Fix(Num)
lDec = Round(Num - lCel, 5)
'MsgBox (lDec)
Hundreds = 0
Thousands = 0
Millions = 0
Milliards = 0


sCel = str(lCel)
lDlina = Len(sCel)
If lCel > 999999999999999# Then
SummaPropis = "слишком большое число! по модулю >999 триллионов"
Exit Function
End If
Hundreds = Val(Right(sCel, 3))
If lCel > 999 Then
Select Case lDlina
Case 3
Thousands = 0
Case 4
Thousands = Val(Left(sCel, 1))
Case 5
Thousands = Val(Left(sCel, 2))
Case Else
Thousands = Val(Mid(sCel, lDlina - 5, 3))
End Select
End If
If lCel > 999999 Then
Select Case lDlina
Case 6
Millions = 0
Case 7
Millions = Val(Left(sCel, 1))
Case 8
Millions = Val(Left(sCel, 2))
Case Else
Millions = Val(Mid(sCel, lDlina - 8, 3))
End Select
End If
If lCel > 999999999 Then
Select Case lDlina
Case 9
Milliards = 0
Case 10
Milliards = Val(Left(sCel, 1))
Case 11
Milliards = Val(Left(sCel, 2))
Case Else
Milliards = Val(Mid(sCel, lDlina - 11, 3))
End Select
End If
If lCel > 999999999999# Then
Select Case lDlina
Case 12
Trillions = 0
Case 13
Trillions = Val(Left(sCel, 1))
Case 14
Trillions = Val(Left(sCel, 2))
Case Else
Trillions = Val(Mid(sCel, lDlina - 14, 3))
End Select
End If


If lCel = 0 And lDec <> 0 Then
SummaPropis = SummaPropis & "ноль целых "
Else
SummaPropis = SummaPropis & SummaPropisTriada(Trillions, "триллион", "триллиона", "триллионов", "м") & SummaPropisTriada(Milliards, "миллиард", "миллиарда", "миллиардов", "м") & SummaPropisTriada(Millions, "миллион", "миллиона", "миллионов", "м") & SummaPropisTriada(Thousands, "тысяча", "тысячи", "тысяч", "ж") & IIf(lDec = 0, IIf(Hundreds = 0 And lCel > 999, SummaPropisTriada(Hundreds, String1, String234, StringOther, sPol, True), SummaPropisTriada(Hundreds, String1, String234, StringOther, sPol)), SummaPropisTriada(Hundreds, "целая", "целых", "целых", "ж"))
End If


If lDec <> 0 Then
lDlina = Len(str(lDec)) - 2
lDec = Val(Right(str(lDec), Len(str(lDec)) - 2))
sDec = LTrim(str(lDec))

Hundreds = Val(Right(sDec, 3))
If lDec > 999 Then
Select Case lDlina
Case 3
Thousands = 0
Case 4
Thousands = Val(Left(sDec, 1))
Case 5
Thousands = Val(Left(sDec, 2))
Case Else
Thousands = Val(Mid(sDec, lDlina - 5, 3))
End Select
Else
Thousands = 0
End If
If lDec > 999999 Then
Select Case lDlina
Case 6
Millions = 0
Case 7
Millions = Val(Left(sDec, 1))
Case 8
Millions = Val(Left(sDec, 2))
Case Else
Millions = Val(Mid(sDec, lDlina - 8, 3))
End Select
Else
Millions = 0
End If
If lDec > 999999999 Then
Select Case lDlina
Case 9
Milliards = 0
Case 10
Milliards = Val(Left(sDec, 1))
Case 11
Milliards = Val(Left(sDec, 2))
Case Else
Milliards = Val(Mid(sDec, lDlina - 11, 3))
End Select
Else
Milliards = 0
End If
If lDec > 999999999999# Then
Select Case lDlina
Case 12
Trillions = 0
Case 13
Trillions = Val(Left(sDec, 1))
Case 14
Trillions = Val(Left(sDec, 2))
Case Else
Trillions = Val(Mid(sDec, lDlina - 14, 3))
End Select
Else
Trillions = 0
End If

SummaPropis = SummaPropis & SummaPropisTriada(Trillions, "триллион", "триллиона", "триллионов", "м") & SummaPropisTriada(Milliards, "миллиард", "миллиарда", "миллиардов", "м") & SummaPropisTriada(Millions, "миллионн", "миллионна", "миллионнов", "м") & SummaPropisTriada(Thousands, "тысяча", "тысячи", "тысяч", "ж") & SummaPropisTriada(Hundreds, Choose(lDlina, "десятая", "сотая", "тысячная", "десятитысячная", "стотысячная", "миллионная", "милиардная", "трилионная"), Choose(lDlina, "десятых", "сотых", "тысячных", "десятитысячных", "стотысячных", "миллионных", "милиардных", "трилионных"), Choose(lDlina, "десятых", "сотых", "тысячных", "десятитысячных", "стотысячных", "миллионных", "милиардных", "трилионных"), "ж") & SummaPropisTriada(Hundreds, StringChego, StringChego, StringChego, sPol, True)

End If

End Function

Function SummaPropisTriada(ByVal lTriada As Long, String1 As String, String234 As String, StringOther As String, sPol As String, Optional IsNumHidden As Boolean = False) As String
'Вспомогательная функция для главной функции - SummaPropis
'переводит в текстовое представление число, длина которого <= 3
'(триаду)
'lTriada - триада (123, 1, 0, 22, 987 и т.д.)
'Первое слово - "одна что? - штука"
'Второе слово - "две, три, четыре чего? - штуки"
'Третье слово - "пять, шесть, семь, 100, 355, и т.д чего? - штук"
'Четвертое слово - "одна десятая чего? - штуки"
'Пятое слово - "пол штуки какой? - женский ("ж")"
'
'Последний параметр опциональный:
'TRUE - НЕ ВЫДАВАТЬ ЧИСЛО ПРОПИСЬЮ, а выдавать только предмет подсчета
'FALSE (по умолчанию) - ВЫДАВАТЬ И ЧИСЛО и ПРЕДМЕТ подсчета
'Например SummaPropisTriada(52,"книга","книги","книг","книги","ж",False)
' Вернет "пятьдесят две книги"
' (так же как и SummaPropisTriada(52,"книга","книги","книг","книги","ж"))
' А SummaPropisTriada(52,"книга","книги","книг","книги","ж",True)
' Просто вернет "книги"

Dim l1 As Long
Dim l10 As Long
Dim l100 As Long
Dim bMale As Boolean
Dim iPol As Integer
SummaPropisTriada = ""
If lTriada = 0 And Not IsNumHidden Then Exit Function
l1 = 0
l10 = 0
l100 = lTriada \ 100
l10 = lTriada - l100 * 100
l1 = lTriada - l100 * 100 - (l10 \ 10) * 10
Select Case sPol
Case "м"
iPol = 1
Case "ж"
iPol = 2
Case "с"
iPol = 3
Case Else
iPol = 1
End Select

If l100 <> 0 And Not IsNumHidden Then
SummaPropisTriada = Choose(l100, "сто", "двести", "триста", "четыреста", "пятьсот", "шестьсот", "семьсот", "восемьсот", "девятьсот")
SummaPropisTriada = SummaPropisTriada & " "
End If

If l10 = 10 Then
If Not IsNumHidden Then SummaPropisTriada = SummaPropisTriada & "десять"
SummaPropisTriada = SummaPropisTriada & " " & StringOther & " "
Exit Function
Else
If l10 >= 11 And l10 <= 19 Then
If Not IsNumHidden Then SummaPropisTriada = SummaPropisTriada & Choose(l1, "одиннадцать", "двенадцать", "тринадцать", "четырнадцать", "пятнадцать", "шестнадцать", "семнадцать", "восемнадцать", "девятнадцать")
SummaPropisTriada = SummaPropisTriada & " " & StringOther & " "
Exit Function
Else
If Not IsNumHidden Then
SummaPropisTriada = SummaPropisTriada & Choose(l10 \ 10, "", "двадцать", "тридцать", "сорок", "пятьдесят", "шестьдесят", "семьдесят", "восемьдесят", "девяносто")
SummaPropisTriada = SummaPropisTriada & " "
End If
End If

End If
If l1 <> 0 Then
If Not IsNumHidden Then
SummaPropisTriada = SummaPropisTriada & Choose(l1, Choose(iPol, "один", "одна", "одно"), Choose(iPol, "два", "две", "два"), "три", "четыре", "пять", "шесть", "семь", "восемь", "девять")
SummaPropisTriada = SummaPropisTriada & " "
End If
End If
If lTriada <> 0 Then
SummaPropisTriada = SummaPropisTriada & Choose(l1 + 1, StringOther, String1, String234, String234, String234, StringOther, StringOther, StringOther, StringOther, StringOther)
SummaPropisTriada = SummaPropisTriada & " "
End If
If lTriada = 0 And IsNumHidden Then
SummaPropisTriada = SummaPropisTriada & StringOther
SummaPropisTriada = SummaPropisTriada & " "
End If
End Function
Public Function Round( _
ByVal Number As Variant, NumDigits As Long, _
Optional UseBankersRounding As Boolean = False) As Double
'ЕЩЕ ОДНА ВСПОМОГАТЕЛЬНАЯ ФУНКЦИЯ (НЕ МОЯ!), округляет указанное число, до указанной точности
'Here s the version I recently wrote that solves that last issue. I've
'sent this in to Advisor to post as an errata. I think this will work
'now... -- Ken
Dim dblPower As Double
Dim varTemp As Variant
Dim intSgn As Integer

If Not IsNumeric(Number) Then
' Raise an error indicating that
' you've supplied an invalid parameter.
Err.Raise 5
End If
dblPower = 10 ^ NumDigits
' Do the major calculation.
varTemp = CDec(Number) * dblPower + 0.5

' Now round to nearest even, if necessary.
If UseBankersRounding Then
' Is this a negative number, or not?
' intSgn will contain -1, 0, or 1.
intSgn = Sgn(Number)
varTemp = Abs(varTemp)
If Int(varTemp) = varTemp Then
If varTemp Mod 2 = 1 Then
' If working with a negative number,
' add 1. If working with a
' positive number, subtract one.
' That's what "- intSgn" will do.
varTemp = _
intSgn * (varTemp - intSgn)
End If
End If
End If
' Finish the calculation.
Round = Int(varTemp) / dblPower
End Function


'===================
'Функция для примера
'===================
Public Function SummaPropisQty(Num As Variant) As String
'Выдает кол-во штук
'Num -число
'Первое слово - "одна что? - штука"
'Второе слово - "две, три, четыре чего? - штуки"
'Третье слово - "пять, шесть, семь, 100, 355, и т.д чего? - штук"
'Четвертое слово - "одна десятая чего? - штуки"
'Пятое слово - "пол штуки какой? - женский ("ж")"
SummaPropisQty = SummaPropis(Num, "штука", "штуки", "штук", "штуки", "ж")
End Function
Public Function SummaPropisUSD(Num As Variant) As String
'Выдает кол-во долларов США
SummaPropisUSD = SummaPropis(Num, "доллар США", "доллара США", "долларов США", "доллара США", "м")
End Function
Public Function SummaPropisRUR(Num As Variant) As String
'Выдает кол-во рублей
SummaPropisRUR = SummaPropis(Num, "рубль", "рубля", "рублей", "рубля", "м")
End Function
Public Function SummaPropisYen(Num As Variant) As String
'Выдает кол-во Иен
SummaPropisYen = SummaPropis(Num, "японская Иена", "японских Иены", "японских Иен", "японской Иены", "ж")
End Function
Public Function SummaPropisDM(Num As Variant) As String
'Выдает кол-во немецких марок
SummaPropisDM = SummaPropis(Num, "немецкая марка", "немецких марки", "немецких марок", "немецкой марки", "ж")
End Function
Public Function SummaPropisCrocodile(Num As Variant) As String
'Выдает кол-во крокодилов ;-)
SummaPropisCrocodile = SummaPropis(Num, "крокодил", "крокодила", "крокодилов", "крокодила", "м")
'если поставить пол крокодила "ж" - получится забавно ;-)
End Function