Visual2000 · Архив статей А.Колесова & О.Павловой
Андрей Колесов, Ольга Павлова
© 2000, Андрей Колесов, Ольга ПавловаЗадача автоматического представления числового значения прописью является одной из наиболее часто встречающихся при составлении юридических документов. При этом речь может идти не только о денежных суммах, но и о количестве каких-либо товаров.
Кстати, многие из первых макросов, присланных для конкурса MS Office Extensions (www.microsoft.ru/offext/) еще в 1997 году, решали именно эту задачу и некоторые из них получили призы. Но предлагаемые там решения имеют уже "встроенный" характер, к тому же, на наш взгляд, не очень универсальны и оптимальны. Исходный код у многих таких расширений закрыт, а у тех, где открыт, требует, честно говоря, слишком больших усилий, чтобы в них разобраться.
Поэтому мы решили предложить читателям собственный вариант.
В листинге 227 находится процедура SummaString, которая в свою очередь использует внутреннюю служебную подпрограмму SummaStringThree. Там же имеется описание входных и выходных параметров. Эта процедура учитывает правильное склонение числительных в зависимости от рода единицы измерения (мужской, женский, средний) и ее практическое применение может выглядеть следующим образом:
Source& = 2000011 CALL SummaString(Summa$, Source&, 1, "рубль", "рубля", "рублей") Print Summa$ ' два миллиона одиннадцать рублей ' Source& = 22 CALL SummaString(Summa$, Source&, 2, "копейка", "копейки", "копеек") Print Summa$ ' двадцать две копейки ' Source& = 1231 Call SummaString(Summa$, Source&, 3, "колесо", "колеса", "колес") Print Summa$ ' одна тысяча двести тридцать одно колесо ' Call SummaString(Summa$, Source&, 1, "", "", "") Print Summa$ ' одна тысяча двести тридцать один Print Summa$ + " руб." ' одна тысяча двести тридцать один руб.
Еще несколько дополнительных замечаний:
Чтобы выполнить нужное преобразование независимо от версии VB и системных установок Windows, гораздо проще применить следующую конструкцию:
Mid$(Summa$, 1) = Chr$(Asc(Summa$) - 32)
Для DOS-овских версий, в которых преобразование регистра выполняется только для английских букв, такая операция будет выглядеть немного сложнее (альтернативная русская таблица DOS - cp866):
s% = ASC(Summa$) IF s% <= 175 THEN s% = s% - 32 ELSE s% = s% = 80 MID$(Summa$, 1) = CHR$(s%)
Здесь мы воспользовались тем обстоятельством, что полученная символьная строка гарантированно (так работает наш алгоритм) начинается со строчной русской буквы. В противном случае пришлось бы сделать небольшую проверку на попадание ASCII- кода в нужный диапазон.
Sub SummaString(Summa$, Source As Long, Rod%, w1$, w2to4$, w5to10$)
'
' "Сумма прописью":
' преобразование числа из цифрого вида в символьное
' ==================================================
' Исходные данные:
' Source - число от 0 до 2147483647 (2^31-1)
' Eсли нужно оперировать с числами > 2 147 483 647
' замените описание переменных Source и TempValue на "AS DOUBLE"
'
' далее нужно задать информацию о единице изменения
' Rod% = 1 - мужской, = 2 - женский, = 3 - средний
' название единицы изменения:
' w1$ - именительный падеж единственное число (= 1)
' w2to4$ - родительный падеж единственное число (= 2-4)
' w5to10$ - родительный падеж множественное число ( = 5-10)
'
' Rod% должен быть задано обязательно, название единицы может быть
' не задано = ""
' ———————————————-
' Результат: Summa$ - запись прописью
'
'================================
Dim TempValue As Long
'
If Source& = 0 Then
Summa$ = RTrim$("ноль " + w5to10$): Exit Sub
End If
'
TempValue = Source: Summa$ = ""
' единицы
Call SummaStringThree(Summa$, TempValue, Rod%, w1$, w2to4$, w5to10$)
If TempValue = 0 Then Exit Sub
' тысячи
Call SummaStringThree(Summa$, TempValue, 2, "тысяча", "тысячи", "тысяч")
If TempValue = 0 Then Exit Sub
' миллионы
Call SummaStringThree(Summa$, TempValue, 1, "миллион",
"миллиона", "миллионов")
If TempValue = 0 Then Exit Sub
' миллиардов
Call SummaStringThree(Summa$, TempValue, 1, "миллиард",
"миллиарда", "миллиардов")
If TempValue = 0 Then Exit Sub
'
' Eсли нужно оперировать с числами > 2 147 483 647
' измените тип переменных (см. выше) и добавьте эту строку для триллионов:
' CALL SummaStringThree(Summa$, TempValue#, 1, "трилллион",
"триллиона", "триллионов")
' IF TempValue# = 0 THEN EXIT SUB
'
' Что идет после триллионов, я плохо представляю...
'
End Sub
Sub SummaStringThree(Summa$, TempValue As Long, Rod%, w1$, w2to4$, w5to10$)
'
' Формирования строки для трехзначного числа:
' (последний трех знаков TempValue
' Eсли нужно оперировать с числами > 2 147 483 647
' замените в описании на TempValue AS DOUBLE
'====================================
Dim Rest%, Rest1%, EndWord$, s1$, s10$, s100$
'
Rest% = TempValue& Mod 1000
TempValue& = TempValue& \ 1000
If Rest% = 0 Then ' последние три знака нулевые
If Summa$ = "" Then Summa$ = w5to10$ + " "
Exit Sub
End If
'
' начинаем подсчет с Rest
EndWord$ = w5to10$
' сотни
Select Case Rest% \ 100
Case 0: s100$ = ""
Case 1: s100$ = "сто "
Case 2: s100$ = "двести "
Case 3: s100$ = "триста "
Case 4: s100$ = "четыреста "
Case 5: s100$ = "пятьсот "
Case 6: s100$ = "шестьсот "
Case 7: s100$ = "семьсот "
Case 8: s100$ = "восемьсот "
Case 9: s100$ = "девятьсот "
End Select
'
' десятки
Rest% = Rest% Mod 100: Rest1% = Rest% \ 10
s1$ = ""
Select Case Rest1%
Case 0: s10$ = ""
Case 1 ' особый случай
Select Case Rest%
Case 10: s10$ = "десять "
Case 11: s10$ = "одиннадцать "
Case 12: s10$ = "двенадцать "
Case 13: s10$ = "тринадцать "
Case 14: s10$ = "четырнадцать "
Case 15: s10$ = "пятнадцать "
Case 16: s10$ = "шестнадцать "
Case 17: s10$ = "семнадцать "
Case 18: s10$ = "восемнадцать "
Case 19: s10$ = "девятнадцать "
End Select
Case 2: s10$ = "двадцать "
Case 3: s10$ = "тридцать "
Case 4: s10$ = "сорок "
Case 5: s10$ = "пятьдесят "
Case 6: s10$ = "шестьдесят "
Case 7: s10$ = "семьдесят "
Case 8: s10$ = "восемьдесят "
Case 9: s10$ = "девяносто "
End Select
'
If Rest1% <> 1 Then ' единицы
Select Case Rest% Mod 10
Case 1
Select Case Rod%
Case 1: s1$ = "один "
Case 2: s1$ = "одна "
Case 3: s1$ = "одно "
End Select
EndWord$ = w1$
Case 2
If Rod% = 2 Then s1$ = "две " Else s1$ = "два "
EndWord$ = w2to4$
Case 3: s1$ = "три ": EndWord$ = w2to4$
Case 4: s1$ = "четыре ": EndWord$ = w2to4$
Case 5: s1$ = "пять "
Case 6: s1$ = "шесть "
Case 7: s1$ = "семь "
Case 8: s1$ = "восемь "
Case 9: s1$ = "девять "
End Select
End If
'
' сборка строки
Summa$ = RTrim$(RTrim$(s100$ + s10$ + s1$ + EndWord$) + " " + Summa$)
End Sub
Вопрос можно сформулировать по-другому: как получить исходное числовое значение Source, которое может быть задано в виде символьной цифровой строки? Для этого можно также использовать функцию ResultSumma$ (листинг 228), которая сначала выполняет необходимые проверки на допустимость преобразования символьной строки в число, а уже потом обращается к SummaSrting.
Например, вы хотите реализовать при работе с документами Word 97/2000 такую дополнительную функцию: выделив некое число, записанное цифрами, легким движением приписать в скобках после этого числа его представление прописью.
Для этого в среде VBA (в нашем случае данный пример реализован в виде документа Summa.doc) необходимо загрузить BAS-модуль с уже созданными нами процедурами ResultString, SummaString и SummaStringThree, а потом написать такую макрокоманду:
Sub ЧислоПрописью()
'
Dim Summa$
Summa$ = ResultSumma$(Selection.Text, 1, "", "", "", 0)
If Summa$ <> "" Then ' допустимое значение
Selection.Text = Selection.Text + " (" + Summa$ + ") "
End If
End Sub
Тогда, выделив в документе, например строку "1732", и обратившись к макрокоманде, вы увидите в тексте: "1732 (одна тысяча семьсот тридцать два)".
При желании можно также написать автономную утилиту (Summa.vbp), которая выполняет нужное преобразование на основе данных, введенных в диалоговом режиме (рис. 228). Обратите внимание, эта утилита сохраняет все параметры, введенные при предыдущем запуске. Данный VB-проект несложно преобразовать в отдельный ActiveX-сервер или интегрировать в среду приложения, поддерживающего технологию VBA.
Рис. 228
Короче говоря, у разработчика открываются широкие возможности по созданию собственного варианта встроенного использования приведенных здесь процедур. Нам кажется, что дальше читатели смогут уже самостоятельно реализовать и такой вариант процедуры или макроса, который, например, преобразует выражение типа "100 руб. 21 коп." в формат "Сто руб. 21 коп.". Будут проблемы - пишите.
Public Function ResultSumma$(Source$, Rod%, w1$, w2to4$, w5to10$, iCase%)
Dim i%, Summa$
' Проверка правильности числа
' и преобразование его в пропись
'
' Source$ - цифровая запись числа в символьном виде
' Rod, w1, w2to4, w5to10 - см. SummaString
' iCase > 0 - первую букву преобразовать в прописную
' ========================
If Source$ = "" Then
MsgBox "Пустая символьная строка"
Exit Function
End If
For i = 1 To Len(Source$)
If Not Mid$(Source$, i, 1) Like "[0-9]" Then
MsgBox "Исходная строка содержит не цифры:" & vbCrLf & Source$
Exit Function
End If
Next
If Val(Source$) > &H7FFFFFFF Then
MsgBox "Превышен предел - 2147483647"
Exit Function
End If
Call SummaString(Summa$, CLng(Val(Source$)), Rod%, w1$, w2to4$, w5to10$)
If iCase% > 0 Then ' написать с прописной буквы
Mid$(Summa$, 1) = Chr$(Asc(Summa$) - 32)
End If
ResultSumma$ = Summa$
End Function