Function ЧИСЛИТ(число As Double, Optional текст As String = "RUB", Optional дробная_часть As Boolean = True) As String
'
Dim DROB As String ' Дробная часть входящего значения
Dim DROBCHIS As String ' текст дробной части
Dim CHISLITELNOE As String ' Результирующее числительное (текст)
Dim CELOE As String ' Целая часть входящего значения (текст)
Dim CHAST As String
Dim clValuta As String
Dim drVALUTA As String
Dim n() As String ' Отдельная цифра целой части входящего значения (текст)
Dim CIFRA() As String ' Отдельное числительное (текст)
Dim RAZRJAD() As String ' Наименование разряда числа (текст)
'
If Sgn(число) = -1 Then число = Abs(число) ' Если значение отрицательное обрабатывается его абсолютное значение
CELOE = Trim$(Str(Fix(число + 0.0001))) ' Удаление пробелов и отбрасывание дробной части
DROB = Round((число - Val(CELOE)) + 0.0001, 2) * 100 ' Дробная часть
If Len(DROB) = 1 Then DROB = "0" & DROB
ReDim n(Len(CELOE)) As String ' Определение размерности массивов
ReDim CIFRA(Len(CELOE)) As String
ReDim RAZRJAD(Len(CELOE)) As String
CHISLITELNOE = vbNullString
DROBCHIS = vbNullString
CHAST = CELOE
For I = 1 To Len(CELOE) ' Основной блок процедуры
n(I) = Mid$(CELOE, Len(CELOE) - I + 1, 1)
GoSub EdinizyIdesyatki
If I = 3 Or I = 6 Or I = 9 Or I = 12 Then
' Сотни
If n(I) = "0" Then CIFRA(I) = vbNullString
If n(I) = "1" Then CIFRA(I) = "сто "
If n(I) = "2" Then CIFRA(I) = "двести "
If n(I) = "3" Then CIFRA(I) = "триста "
If n(I) = "4" Then CIFRA(I) = "четыреста "
If n(I) = "5" Then CIFRA(I) = "пятьсот "
If n(I) = "6" Then CIFRA(I) = "шестьсот "
If n(I) = "7" Then CIFRA(I) = "семьсот "
If n(I) = "8" Then CIFRA(I) = "восемьсот "
If n(I) = "9" Then CIFRA(I) = "девятьсот "
End If
' Разряды
' Тысячи
If I = 4 Then
If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "тысяч "
If Val(n(I)) = 1 Then RAZRJAD(I) = "тысяча "
If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "тысячи "
End If
If I = 5 Then
If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "тысяч "
End If
If I = 6 Then
If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
End If
' Миллионы
If I = 7 Then
If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллионов "
If Val(n(I)) = 1 Then RAZRJAD(I) = "миллион "
If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиона "
End If
If I = 8 Then
If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллионов "
End If
If I = 9 Then
If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
End If
' Миллиарды
If I = 10 Then
If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллиардов "
If Val(n(I)) = 1 Then RAZRJAD(I) = "миллиард "
If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиарда "
End If
If I = 11 Then
If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллиардов "
End If
' При необходимости преобразования бОльших чисел - активизировать следующую часть кода,
' вставить блок разрядов (например "Триллионы") и отредактировать его в соответствии с новым разрядом
' If I = 12 Then
' If Val(N(I)) = 0 And Val(N(I - 1)) = 0 And Val(N(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
' End If
Next I
For I = 1 To Len(CELOE) ' Формирование числительного
CHISLITELNOE = CIFRA(I) & RAZRJAD(I) & CHISLITELNOE
Next I
Mid$(CHISLITELNOE, 1, 1) = StrConv(Left$(CHISLITELNOE, 1), vbProperCase)
ReDim n(Len(DROB)) As String ' переопределение размерности массивов
ReDim CIFRA(Len(DROB)) As String
CHAST = DROB
For I = 1 To Len(DROB) ' преобразование дробной части
n(I) = Mid$(DROB, Len(DROB) - I + 1, 1)
GoSub EdinizyIdesyatki
Next I
For I = 1 To Len(DROB) ' Формирование дробной части числительного
DROBCHIS = CIFRA(I) & Trim$(DROBCHIS)
Next I
DROBOR = IIf(дробная_часть, Trim$(DROBCHIS), DROB)
' Наименование валюты
If текст = "USD" Then
clValuta = "долл.США " 'Принеобходимости применения полного наименования валюты необходимо
'закомментировать текущую строку и активировать следующие четыре
'If Val(Right$(CELOE, 1)) = 0 Or Val(Right$(CELOE, 1)) > 4 Then clValuta = "долларов США "
'If Val(Right$(CELOE, 1)) = 1 Then clValuta = "доллар США "
'If Val(Right$(CELOE, 1)) >= 2 And Val(Right$(CELOE, 1)) <= 4 Then clValuta = "доллара США "
'If Val(Right$(CELOE, 2)) >= 10 And Val(Right$(CELOE, 2)) <= 19 Then clValuta = "долларов США "
If Val(Right$(DROB, 1)) = 0 Or Val(Right$(DROB, 1)) > 4 Then drVALUTA = " центов."
If Val(Right$(DROB, 1)) = 1 Then drVALUTA = " цент."
If Val(Right$(DROB, 1)) >= 2 And Val(Right$(DROB, 1)) <= 4 Then drVALUTA = " цента."
If Val(Right$(DROB, 2)) >= 10 And Val(Right$(DROB, 2)) <= 19 Then drVALUTA = " центов."
End If
If текст = "AMD" Then
clValuta = "драм "
If Val(Right$(CELOE, 1)) >= 2 And Val(Right$(CELOE, 1)) <= 4 Then clValuta = "драма " Else clValuta = "драм "
If Val(Right$(CELOE, 2)) >= 10 And Val(Right$(CELOE, 2)) <= 19 Then clValuta = "драм "
drVALUTA = " лум."
End If
If текст = "RUB" Then
' clValuta = "руб. " 'Принеобходимости применения полного наименования валюты необходимо
'закомментировать текущую строку и активировать следующие четыре
If Val(Right$(CELOE, 1)) = 0 Or Val(Right$(CELOE, 1)) > 4 Then clValuta = "рублей "
If Val(Right$(CELOE, 1)) = 1 Then clValuta = "рубль "
If Val(Right$(CELOE, 1)) >= 2 And Val(Right$(CELOE, 1)) <= 4 Then clValuta = "рубля "
If Val(Right$(CELOE, 2)) >= 10 And Val(Right$(CELOE, 2)) <= 19 Then clValuta = "рублей "
If DROBOR <> DROB Then
If Right$(DROBOR, 4) = "один" Then Mid$(DROBOR, InStrRev(DROBOR, " ") + 1, 4) = "одна"
If Right$(DROBOR, 3) = "два" Then Mid$(DROBOR, InStrRev(DROBOR, " ") + 1, 3) = "две"
End If
If Val(Right$(DROB, 1)) = 0 Or Val(Right$(DROB, 1)) > 4 Then drVALUTA = " копеек."
If Val(Right$(DROB, 1)) = 1 Then drVALUTA = " копейка."
If Val(Right$(DROB, 1)) >= 2 And Val(Right$(DROB, 1)) <= 4 Then drVALUTA = " копейки."
If Val(Right$(DROB, 2)) >= 10 And Val(Right$(DROB, 2)) <= 19 Then drVALUTA = " копеек."
End If
If текст = "EUR" Then
clValuta = "евро "
If Val(Right$(DROB, 1)) = 0 Or Val(Right$(DROB, 1)) > 4 Then drVALUTA = " центов."
If Val(Right$(DROB, 1)) = 1 Then drVALUTA = " цент."
If Val(Right$(DROB, 1)) >= 2 And Val(Right$(DROB, 1)) <= 4 Then drVALUTA = " цента."
If Val(Right$(DROB, 2)) >= 10 And Val(Right$(DROB, 2)) <= 19 Then drVALUTA = " центов."
End If
ЧИСЛИТ = CHISLITELNOE & clValuta & DROBOR & drVALUTA
Exit Function
EdinizyIdesyatki: 'Подпрограмма обработки единиц и десятков
' Единицы
If I = 1 Or I = 4 Or I = 7 Or I = 10 Then
If Len(CHAST) = 1 And n(I) = "0" Or CHAST = "00" Then CIFRA(I) = "ноль "
If n(I) = "1" Then CIFRA(I) = "один "
If I = 4 And n(I) = "1" Then CIFRA(I) = "одна " ' единицы тысяч
If n(I) = "2" Then CIFRA(I) = "два "
If I = 4 And n(I) = "2" Then CIFRA(I) = "две " ' единицы тысяч
If n(I) = "3" Then CIFRA(I) = "три "
If n(I) = "4" Then CIFRA(I) = "четыре "
If n(I) = "5" Then CIFRA(I) = "пять "
If n(I) = "6" Then CIFRA(I) = "шесть "
If n(I) = "7" Then CIFRA(I) = "семь "
If n(I) = "8" Then CIFRA(I) = "восемь "
If n(I) = "9" Then CIFRA(I) = "девять "
End If
' Десятки
If I = 2 Or I = 5 Or I = 8 Or I = 11 Then
If n(I) = "0" Then CIFRA(I) = vbNullString
If n(I) = "1" And n(I - 1) = "0" Then CIFRA(I - 1) = "десять "
If n(I) = "1" And n(I - 1) = "1" Then CIFRA(I - 1) = "одиннадцать "
If n(I) = "1" And n(I - 1) = "2" Then CIFRA(I - 1) = "двенадцать "
If n(I) = "1" And n(I - 1) = "3" Then CIFRA(I - 1) = "тринадцать "
If n(I) = "1" And n(I - 1) = "4" Then CIFRA(I - 1) = "четырнадцать "
If n(I) = "1" And n(I - 1) = "5" Then CIFRA(I - 1) = "пятнадцать "
If n(I) = "1" And n(I - 1) = "6" Then CIFRA(I - 1) = "шестнадцать "
If n(I) = "1" And n(I - 1) = "7" Then CIFRA(I - 1) = "семнадцать "
If n(I) = "1" And n(I - 1) = "8" Then CIFRA(I - 1) = "восемнадцать "
If n(I) = "1" And n(I - 1) = "9" Then CIFRA(I - 1) = "девятнадцать "
If n(I) = "2" Then CIFRA(I) = "двадцать "
If n(I) = "3" Then CIFRA(I) = "тридцать "
If n(I) = "4" Then CIFRA(I) = "сорок "
If n(I) = "5" Then CIFRA(I) = "пятьдесят "
If n(I) = "6" Then CIFRA(I) = "шестьдесят "
If n(I) = "7" Then CIFRA(I) = "семьдесят "
If n(I) = "8" Then CIFRA(I) = "восемьдесят "
If n(I) = "9" Then CIFRA(I) = "девяносто "
End If
Return
End Function |