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

Ссылка на оригинал

Время создания: 16.03.2019 23:43

Раздел: Разные закладки - VBA - Access - msa.polarcom.ru - 14 Преобразование Чисел и Дат

Запись: xintrea/mytetra_db_adgaver_new/master/base/15320184763rl7usb3lc/text.html на raw.githubusercontent.com

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

Автор: Дмитрий Милосердов 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

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

If l1 <> 0 Then

If Not IsNumHidden Then

SummaPropisTriada = SummaPropisTriada & Choose(l1, Choose(iPol, "один", "одна", "одно"), Choose(iPol, "два", "две", "два"), "три", "четыре", "пять", "шесть", "семь", "восемь", "девять")

SummaPropisTriada = SummaPropisTriada & " "

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

' 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

Так же в этом разделе:

MyTetra Share v.0.65