ReSQL.ru
     
powered by simpleCommunicator - 2.0.51     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Access [игнор отключен] [закрыт для гостей] / Сумма прописью
67 сообщений из 67, показаны все 3 страниц
  все  
Сумма прописью
    #32776739
Alex_from_Spb
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Alex_from_Spb
Гость
Здравствуйте всем. Не подскажет ли кто, есть ли в MS Access 2000/XP встроенная функция (или, уже, может, есть разработанная кем-то) по типу как в 1С, которая позволяет преобразовывать денежные суммы в цифрах в суммы прописью (необходимо для отчета - ТТН в складской программе). В справке и умных книжках по Access ничего на эту тему не нашел, а в форуме копаться просто нет времени. Буду очень благодарен.
...
Рейтинг: 0 / 0
11.11.2004, 10:04
| Ответить | Цитировать | Написать  
Сумма прописью
    #32776807
RVI
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
RVI
Участник
Смотри здесь
...
Рейтинг: 0 / 0
11.11.2004, 10:25
| Ответить | Цитировать | Написать  
Сумма прописью
    #32776999
Alex_from_Spb
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Alex_from_Spb
Гость
Спасибо огромное, будем разбираться.
...
Рейтинг: 0 / 0
11.11.2004, 11:20
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777172
Terabucks
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Terabucks
Гость
А вот вариант покороче. Написан мною в 1999 :)

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
Public Function NumberToText(Number As Currency) As String
'!Функция орределена на интервале [-922 337 203 685 477,5808;922 337 203 685 477,5807] в силу ограничения
'!накладываемого на аргумент типом данных Currency.
'!Функция расчитана на работу с целочисленными аргументами. В противном случае функция выдает ошибочное значение



On Error GoTo err:
Dim i, j As Integer

    'Dim Number As Currency 'Область определения функции от -922 337 203 685 477,5808 до 922 337 203 685 477,5807
    Dim FirstData( 0  To  9 ) As String
    Dim razr( 1  To  16 ) As String
        'razr1 - единицы
        'razr2 - десятки
        'razr3 - сотни
        'razr4 - тысячи
        'razr5 - десятки тысяч
        'razr6 - сотни тысяч
        'razr7 - миллионы
        'razr8 - десятки мллионов
        'razr9 - сотни миллионов
        'razr10 - миллиарды
        'razr11 - десятки миллиардов
        'razr12 - сотни миллиардов
        'razr13 - трилионы
        'razr14 - десятки трлионов
        'razr15 - сотни трилионов
        
    Dim Text( 1  To  16 ) As String
            FirstData( 1 ) = "один"
            FirstData( 2 ) = "два"
            FirstData( 3 ) = "три"
            FirstData( 4 ) = "четыре"
            FirstData( 5 ) = "пять"
            FirstData( 6 ) = "шесть"
            FirstData( 7 ) = "семь"
            FirstData( 8 ) = "восемь"
            FirstData( 9 ) = "девять"
            FirstData( 0 ) = "ноль"

   'Number = InputBox("Enter number!")
        
        For i =  1  To  15 
                razr(i) = Left(Right(Str$(Fix(Number)), i),  1 )
        Next i
        
        
        
        If Number =  0  Then Text( 1 ) = "ноль рублей"
        
        Select Case razr( 1 )
        Case  1 
            If razr( 2 ) <> "1" Then Text( 1 ) = "один рубль" Else Text( 1 ) = "одинадцать рублей"
        Case  2 
            If razr( 2 ) <> "1" Then Text( 1 ) = "два рубля" Else Text( 1 ) = "двенадцать рублей"
        Case  3 
            If razr( 2 ) <> "1" Then Text( 1 ) = "три рубля" Else Text( 1 ) = "тринадцать рублей"
        Case  4 
            If razr( 2 ) <> "1" Then Text( 1 ) = "четыре рубля" Else Text( 1 ) = "четырнадцать рублей"
        Case  5 
            If razr( 2 ) <> "1" Then Text( 1 ) = "пять рублей" Else Text( 1 ) = "пятнадцать рублей"
        Case  6 
            If razr( 2 ) <> "1" Then Text( 1 ) = "шесть рублей" Else Text( 1 ) = "шестнадцать рублей"
        Case  7 
            If razr( 2 ) <> "1" Then Text( 1 ) = "семь рублей" Else Text( 1 ) = "семнадцать рублей"
        Case  8 
            If razr( 2 ) <> "1" Then Text( 1 ) = "восемь рублей" Else Text( 1 ) = "восемнадцать рублей"
        Case  9 
            If razr( 2 ) <> "1" Then Text( 1 ) = "девять рублей" Else Text( 1 ) = "девятнадцать рублей"
        Case  0 
            If razr( 2 ) <> "1" Then Text( 1 ) = "рублей" Else Text( 1 ) = "десять рублей"
        End Select
        
        
        For i =  2  To  14  Step  3 
        Select Case razr(i)
            Case  1 
                Text(i) = ""
            Case  2 
                Text(i) = "двадцать"
            Case  3 
                Text(i) = "тридцать"
            Case  4 
                Text(i) = "сорок"
            Case  5 
                Text(i) = "пятьдесят"
            Case  6 
                Text(i) = "шестьдесят"
            Case  7 
                Text(i) = "семьдесят"
            Case  8 
                Text(i) = "восемьдесят"
            Case  9 
                Text(i) = "девяносто"
            Case  0 
                Text(i) = ""
        End Select
        Next i
        
        For i =  3  To  15  Step  3 
            Select Case razr(i)
                Case  1 
                    Text(i) = "сто"
                Case  2 
                    Text(i) = "двести"
                Case  3 
                    Text(i) = "триста"
                Case  4 
                    Text(i) = "четыреста"
                Case  5 
                    Text(i) = "пятьсот"
                Case  6 
                    Text(i) = "шестьсот"
                Case  7 
                    Text(i) = "семьсот"
                Case  8 
                    Text(i) = "восемьсот"
                Case  9 
                    Text(i) = "девятьсот"
                Case  0 
                Text(i) = ""
            End Select
        Next i
        
    
        Select Case razr( 4 )
        Case  1 
            If razr( 5 ) <> "1" Then Text( 4 ) = "одна тысяча" Else Text( 4 ) = "одинадцать тысяч"
        Case  2 
            If razr( 5 ) <> "1" Then Text( 4 ) = "две тысячи" Else Text( 4 ) = "двенадцать тысяч"
        Case  3 
            If razr( 5 ) <> "1" Then Text( 4 ) = "три тысячи" Else Text( 4 ) = "тринадцать тысяч"
        Case  4 
            If razr( 5 ) <> "1" Then Text( 4 ) = "четыре тысячи" Else Text( 4 ) = "четырнадцать тысяч"
        Case  5 
            If razr( 5 ) <> "1" Then Text( 4 ) = "пять тысяч" Else Text( 4 ) = "пятнадцать тысяч"
        Case  6 
            If razr( 5 ) <> "1" Then Text( 4 ) = "шесть тысяч" Else Text( 4 ) = "шестнадцать тысяч"
        Case  7 
            If razr( 5 ) <> "1" Then Text( 4 ) = "семь тысяч" Else Text( 4 ) = "семнадцать тысяч"
        Case  8 
            If razr( 5 ) <> "1" Then Text( 4 ) = "восемь тысяч" Else Text( 4 ) = "восемнадцать тысяч"
        Case  9 
            If razr( 5 ) <> "1" Then Text( 4 ) = "девять тысяч" Else Text( 4 ) = "девятнадцать тысяч"
        Case  0 
            If razr( 5 ) <> "1" Then Text( 4 ) = "тысяч" Else Text( 4 ) = "десять тысяч"
            If razr( 5 ) = "0" And razr( 6 ) = "0" Then Text( 4 ) = ""
        End Select
        
                    
        
        Select Case razr( 7 )
        Case  1 
            If razr( 8 ) <> "1" Then Text( 7 ) = "один миллион " Else Text( 7 ) = "одинадцать миллионов"
        Case  2 
            If razr( 8 ) <> "1" Then Text( 7 ) = "два миллиона" Else Text( 7 ) = "двенадцать миллионов"
        Case  3 
            If razr( 8 ) <> "1" Then Text( 7 ) = "три миллиона" Else Text( 7 ) = "тринадцать миллионов"
        Case  4 
            If razr( 8 ) <> "1" Then Text( 7 ) = "четыре миллиона" Else Text( 7 ) = "четырнадцать миллионов"
        Case  5 
            If razr( 8 ) <> "1" Then Text( 7 ) = "пять миллионов" Else Text( 7 ) = "пятнадцать миллионов"
        Case  6 
            If razr( 8 ) <> "1" Then Text( 7 ) = "шесть миллионов" Else Text( 7 ) = "шестнадцать миллионов"
        Case  7 
            If razr( 8 ) <> "1" Then Text( 7 ) = "семь миллионов" Else Text( 7 ) = "семнадцать миллионов"
        Case  8 
            If razr( 8 ) <> "1" Then Text( 7 ) = "восемь миллионов" Else Text( 7 ) = "восемнадцать миллионов"
        Case  9 
            If razr( 8 ) <> "1" Then Text( 7 ) = "девять миллионов" Else Text( 7 ) = "девятнадцать миллионов"
        Case  0 
            If razr( 8 ) <> "1" Then Text( 7 ) = "миллионов" Else Text( 7 ) = "десять миллионов"
            If razr( 8 ) = "0" And razr( 9 ) = "0" Then Text( 7 ) = ""
        End Select
        
        Select Case razr( 10 )
        Case  1 
            If razr( 11 ) <> "1" Then Text( 10 ) = "один миллиард " Else Text( 10 ) = "одинадцать миллиардов"
        Case  2 
            If razr( 11 ) <> "1" Then Text( 10 ) = "два миллиарда" Else Text( 10 ) = "двенадцать миллиардов"
        Case  3 
            If razr( 11 ) <> "1" Then Text( 10 ) = "три миллиарда" Else Text( 10 ) = "тринадцать миллиардов"
        Case  4 
            If razr( 11 ) <> "1" Then Text( 10 ) = "четыре миллиарда" Else Text( 10 ) = "четырнадцать миллиардов"
        Case  5 
            If razr( 11 ) <> "1" Then Text( 10 ) = "пять миллиардов" Else Text( 10 ) = "пятнадцать миллиардов"
        Case  6 
            If razr( 11 ) <> "1" Then Text( 10 ) = "шесть миллиардов" Else Text( 10 ) = "шестнадцать миллиардов"
        Case  7 
            If razr( 11 ) <> "1" Then Text( 10 ) = "семь миллиардов" Else Text( 10 ) = "семнадцать миллиардов"
        Case  8 
            If razr( 11 ) <> "1" Then Text( 10 ) = "восемь миллиардов" Else Text( 10 ) = "восемнадцать миллиардов"
        Case  9 
            If razr( 11 ) <> "1" Then Text( 10 ) = "девять миллиардов" Else Text( 10 ) = "девятнадцать миллиардов"
        Case  0 
            If razr( 11 ) <> "1" Then Text( 10 ) = "миллиардов" Else Text( 10 ) = "десять миллиардов"
            If razr( 11 ) = "0" And razr( 12 ) = "0" Then Text( 10 ) = ""
        End Select
        
        Select Case razr( 13 )
        Case  1 
            If razr( 14 ) <> "1" Then Text( 13 ) = "один трилион " Else Text( 13 ) = "одинадцать трилионов"
        Case  2 
            If razr( 14 ) <> "1" Then Text( 13 ) = "два трилиона" Else Text( 13 ) = "двенадцать трилионов"
        Case  3 
            If razr( 14 ) <> "1" Then Text( 13 ) = "три трилиона" Else Text( 13 ) = "тринадцать трилионов"
        Case  4 
            If razr( 14 ) <> "1" Then Text( 13 ) = "четыре трилиона" Else Text( 13 ) = "четырнадцать трилионов"
        Case  5 
            If razr( 14 ) <> "1" Then Text( 13 ) = "пять трилионов" Else Text( 13 ) = "пятнадцать трилионов"
        Case  6 
            If razr( 14 ) <> "1" Then Text( 13 ) = "шесть трилионов" Else Text( 13 ) = "шестнадцать трилионов"
        Case  7 
            If razr( 14 ) <> "1" Then Text( 13 ) = "семь трилионов" Else Text( 13 ) = "семнадцать трилионов"
        Case  8 
            If razr( 14 ) <> "1" Then Text( 13 ) = "восемь трилионов" Else Text( 13 ) = "восемнадцать трилионов"
        Case  9 
            If razr( 14 ) <> "1" Then Text( 13 ) = "девять трилионов" Else Text( 13 ) = "девятнадцать трилионов"
        Case  0 
            If razr( 14 ) <> "1" Then Text( 13 ) = "трилионов" Else Text( 13 ) = "десять трилионов"
            If razr( 14 ) = "0" And razr( 15 ) = "0" Then Text( 13 ) = ""
        End Select
                
        For i =  15  To  1  Step - 1 
            If Text(i) <> "" Then Text( 16 ) = Text( 16 ) + Text(i) + " "
        Next i
    NumberToText = Text( 16 )
        'MsgBox Str(Number) + " = " + Text(16)

Exit Function
err:
MsgBox "Don't worry, error!"
End Function
...
Рейтинг: 0 / 0
11.11.2004, 12:02
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777251
еще короче, и функциональней
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
еще короче, и функциональней
Гость
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
Public Function StrValue(ByVal Summ As Double, Optional TypeVal As Byte =  1 ) As String
  Dim recs999(- 3  To  5 ) As Variant
  ' массив описаний числительных:
  ' 1-й аргумент - род: "1" - мужской, "2" - женский, "3" - средний
  ' 5-й аргумент - наименование дробной части, если <>"", то выводится
  ' 6-й аргумент - "1" - добавлять нулевое значение
  recs999(- 3 ) = Array("1", "миллиард", "миллиарда", "миллиардов", "", "")
  recs999(- 2 ) = Array("1", "миллион", "миллиона", "миллионов", "", "")
  recs999(- 1 ) = Array("2", "тысяча", "тысячи", "тысяч", "", "")
  recs999( 0 ) = Array("1", "доллар", "доллара", "долларов", "цент(а,ов)", "1")
  recs999( 1 ) = Array("1", "рубль", "рубля", "рублей", "коп.", "1")
  recs999( 2 ) = Array("2", "штука", "штуки", "штук", "", "1")
  recs999( 3 ) = Array("3", "наименование", "наименования", "наименований", "", "1")
  recs999( 4 ) = Array("1", "", "", "", "", "1")
  recs999( 5 ) = Array("1", "месяц", "месяца", "месяцев", "", "1")
      
  If Summ <  0  Then StrValue = "Минус "
  Summ = Abs(Summ)
  StrValue = StrValue & StrValue999(Summ /  1000000000 , recs999(- 3 )) ' миллиарды
  StrValue = StrValue & StrValue999(Summ /  1000000 , recs999(- 2 )) ' миллионы
  StrValue = StrValue & StrValue999(Summ /  1000 , recs999(- 1 )) ' тысячи
  StrValue = StrValue & StrValue999(Summ, recs999(TypeVal))
  
  StrValue = StrConv(Left(StrValue,  1 ), vbUpperCase) & Trim(Mid(StrValue,  2 ))
End Function

Private Function StrValue999(Summ As Double, TypeVal) As String
  If TypeVal( 5 ) = "1" And Fix(Summ) =  0  Then
    StrValue999 = "ноль " & TypeVal( 3 ) & " "
  Else
    StrValue999 = "" & Choose(Fix(Summ - Fix(Summ /  1000 ) *  1000 ) \  100 , _
      "сто ", "двести ", "триста ", "четыреста ", "пятсот ", _
      "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")
    If Fix(Summ - Fix(Summ /  100 ) *  100 ) >=  11  And Fix(Summ - Fix(Summ /  100 ) *  100 ) <=  19  Then
      StrValue999 = StrValue999 & Choose(Fix(Summ - Fix(Summ /  100 ) *  100 ) -  10 , _
        "одиннадцать", "двенадцать", "тринадцать", "четырнадцать", "пятнадцать", _
        "шестнадцать", "семнадцать", "восемнадцать", "девятнадцать") & " " & TypeVal( 3 ) & " "
    Else
      StrValue999 = StrValue999 & Choose((Fix(Summ - Fix(Summ /  100 ) *  100 )) \  10 , _
        "десять ", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", _
        "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ")
      StrValue999 = StrValue999 & Choose(Fix(Summ - Fix(Summ /  10 ) *  10 ), _
        Choose(TypeVal( 0 ), "один ", "одна ", "одно "), _
        Choose(TypeVal( 0 ), "два ", "две ", "два "), _
        "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ")
      Select Case Fix(Summ - Fix(Summ /  10 ) *  10 )
        Case  1 : StrValue999 = StrValue999 & TypeVal( 1 ) & " "
        Case  2  To  4 : StrValue999 = StrValue999 & TypeVal( 2 ) & " "
        Case Else:
          If Fix((Summ /  1000  - Fix(Summ /  1000 )) *  1000 ) <>  0  Or TypeVal( 5 ) = "1" Then _
            StrValue999 = StrValue999 & TypeVal( 3 ) & " "
      End Select
    End If
  End If
  If TypeVal( 4 ) <> "" Then StrValue999 = StrValue999 & Format((Summ - Fix(Summ)) *  100 , "00") & " " & TypeVal( 4 )
End Function
...
Рейтинг: 0 / 0
11.11.2004, 12:24
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777317
Terabucks
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Terabucks
Гость
Хм. Ну да. Задумка более сильная, учитывая разные наименования единиц измерения и копейки, но:

Код: plaintext
MsgBox StrValue( 7984166000333 #,  1 )

Вместо семь трилионов девятьсот восемьдесят четыре миллиарда сто шестьдесят шесть миллионов триста тридцать три рубля

Ваш вариант выдал Девятьсот восемьдесят четыре миллиарда сто шестьдесят шесть миллионов тысяч триста тридцать три рубля 00 коп., куда-то дев трилионы. Хотя трилионы конечно редко нужны. Но вот слово выделенное жирным совершенно "не в кассу".

Хотя код конечно короче. Я не глумлюсь, а лишь обращаю Ваше внимание на баг.
...
Рейтинг: 0 / 0
11.11.2004, 12:45
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777667
он же
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
он же
Участник
и вправду. Спасибо. Поправил у себя и тут.
...
Рейтинг: 0 / 0
11.11.2004, 14:56
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777682
он же
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
он же
Участник
а с триллионными суммами еще не встречался. Впрочем, чтобы их добавить, надо дописать две строчки:

Код: plaintext
1.
2.
3.
4.
Dim recs999(- 4  To  5 ) As Variant
...
  recs999(- 4 ) = Array("1", "триллион", "триллиона", "триллионов", "", "")
...
  StrValue = StrValue & StrValue999(Summ /  1000000000000 , recs999(- 4 )) ' триллионы

и проверить - возможно, вместо double надо будет использовать currency
...
Рейтинг: 0 / 0
11.11.2004, 15:01
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777689
ззы
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ззы
Гость
ззы. Кстати, этот вариант отнюдь не самый быстрый, он только довольно короткий и простой. А у Андрея Митина вариант более функциональный.
...
Рейтинг: 0 / 0
11.11.2004, 15:03
| Ответить | Цитировать | Написать  
Сумма прописью
    #32777861
Terabucks
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Terabucks
Гость
Согласен. Ваш вариант изящней. :)
...
Рейтинг: 0 / 0
11.11.2004, 16:03
| Ответить | Цитировать | Написать  
Сумма прописью
    #32778086
Фотография Shurgenz
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Shurgenz
Участник
хм... а currency, не возможно, а надо - точно... с округлением и потерями копеек проблем не будет
...
Рейтинг: 0 / 0
11.11.2004, 17:19
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Сумма прописью
    #36216997
Dasyp
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dasyp
Гость
StrValue999 = "" & Choose(Fix(Summ - Fix(Summ / 1000) * 1000) \ 100, _
"сто ", "двести ", "триста ", "четыреста ", "пятсот ", _
"шестьсот ", "семьсот ", "восемьсот ", "девятьсот ")

"пятсот " - надо с мягким знаком сделать. "пятьсот"
...
Рейтинг: 0 / 0
25.09.2009, 12:47
| Ответить | Цитировать | Написать  
Сумма прописью
    #36218305
rok
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
rok
Участник
Рекомендую!
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
Public Function TextSum(numSum As Variant) As String
w$ = Round(numSum,  2 ) 'Входное число - tekst tipа "123.45",защита
'"от дурака" не сделана
'выделение рублей в записи числа и удаление левых пробелов
rubli$ = LTrim$(Left$(Str(Val(w$) *  100 ), _
Len(Str(Val(w$) *  100 )) -  2 ))
cop$ = RTrim$(Right$(Str(CDbl(w$) *  100 ),  2 )) 'выделение дробной части
'числа и удаление правых пробелов

Do While Len(rubli$) <  9 
rubli$ = "0" & rubli$
Loop
res$ = ""
For i% =  1  To  3 
trojka$ = Mid$(rubli$,  3  * i% -  2 ,  3 )
Call Num3(trojka$, i%) ' Вызов функции формирования gotovoй тройки,
'tipа "123 тысячи"
res$ = res$ & trojka$ ' Накопление таких троек
Next i%
'res$ = UCase$(Left$(res$, 1)) & Right$(res$, Len(res$) - 1) 'Запись
'первой буквы res$ в верхнем регистре

c$ = " коп." ' Блок добавления копеек
If (Right$(cop$,  1 ) = "1" And Left$(cop$,  1 ) <> "1") Then c$ = _
" коп."
If ((Right$(cop$,  1 ) = "2" Or Right$(cop$,  1 ) = "3" Or _
Right$(cop$,  1 ) = "4") And Left$(cop$,  1 ) <> "1") Then _
c$ = " коп."
If Left(res$,  1 ) <> "Р" Then res$ = res$ & cop$ & c$ Else _
res$ = cop$ & c$

TextSum = res$ ' Выход tekstа
End Function


Public Function Num3(trojka$, i%)
Dim sl$( 1  To  3 ,  0  To  3 )
sl$( 1 ,  1 ) = "миллион "
sl$( 2 ,  1 ) = "тысяча "
sl$( 3 ,  1 ) = "рубль "
'-
sl$( 1 ,  2 ) = "миллиона "
sl$( 2 ,  2 ) = "тысячи "
sl$( 3 ,  2 ) = "рубля "
'-
sl$( 1 ,  3 ) = "миллионов "
sl$( 2 ,  3 ) = "тысяч "
sl$( 3 ,  3 ) = "рублей "
sl$( 3 ,  0 ) = "рублей "
'-
ed$ = Right$(trojka$,  1 )
des$ = Mid$(trojka$,  2 ,  1 )
sot$ = Left$(trojka$,  1 )
'-
If ed$ = "0" Then r3$ = ""
If ed$ = "1" Then If i% =  2  Then r3$ = "одна " Else r3$ = "один "
If ed$ = "2" Then If i% =  2  Then r3$ = "две " Else r3$ = "два "
If ed$ = "3" Then r3$ = "три "
If ed$ = "4" Then r3$ = "четыре "
If ed$ = "5" Then r3$ = "пять "
If ed$ = "6" Then r3$ = "шесть "
If ed$ = "7" Then r3$ = "семь "
If ed$ = "8" Then r3$ = "восемь "
If ed$ = "9" Then r3$ = "девять "
'-
If des$ = "0" Then r2$ = ""
s$ = des$ & ed$
If s$ = "10" Then r3$ = "десять "
If s$ = "11" Then r3$ = "одиннадцать "
If s$ = "12" Then r3$ = "двенадцать "
If s$ = "13" Then r3$ = "тринадцать "
If s$ = "14" Then r3$ = "четырнадцать "
If s$ = "15" Then r3$ = "пятнадцать "
If s$ = "16" Then r3$ = "шестнадцать "
If s$ = "17" Then r3$ = "семнадцать "
If s$ = "18" Then r3$ = "восемнадцать "
If s$ = "19" Then r3$ = "девятнадцать "
'-
If des$ = "2" Then r2$ = "двадцать "
If des$ = "3" Then r2$ = "тридцать "
If des$ = "4" Then r2$ = "сорок "
If des$ = "5" Then r2$ = "пятьдесят "
If des$ = "6" Then r2$ = "шестьдесят "
If des$ = "7" Then r2$ = "семьдесят "
If des$ = "8" Then r2$ = "восемьдесят "
If des$ = "9" Then r2$ = "девяносто "
'-
If sot$ = "0" Then r1$ = ""
If sot$ = "1" Then r1$ = "сто "
If sot$ = "2" Then r1$ = "двести "
If sot$ = "3" Then r1$ = "триста "
If sot$ = "4" Then r1$ = "четыреста "
If sot$ = "5" Then r1$ = "пятьсот "
If sot$ = "6" Then r1$ = "шестьсот "
If sot$ = "7" Then r1$ = "семьсот "
If sot$ = "8" Then r1$ = "восемьсот "
If sot$ = "9" Then r1$ = "девятьсот "
'-
If trojka$ <> "000" Then j% = (- 1 ) * CInt(ed$ = "1" And des$ <> "1") _
+ (- 2 ) * CInt((ed$ = "2" Or ed$ = "3" Or ed$ = "4") And des$ <> "1")
If j% =  0  And trojka$ <> "000" Then j% =  3 
trojka$ = r1$ & r2$ & r3$ & sl$(i%, j%) 'формирование тройки цифр и
'слова,например-"123 тысячи"
End Function
...
Рейтинг: 0 / 0
25.09.2009, 19:57
| Ответить | Цитировать | Написать  
Сумма прописью
    #36218395
Guest33
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Guest33
Участник
Для коллекции
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
Public V7 As Object

Function ConnectTo1C() As Boolean
Dim path7 As String
On Error Resume Next
ConnectTo1C = False

path7 = "/DD:\1CData\Base2006"
path7 = path7 & " /NБухгалтер" ' User
path7 = path7 & " /P" ' Пароль

Set V7 = CreateObject("V77M.Application")
ConnectTo1C = V7.Initialize(V7.rmtrade, path7, "NO_SPLASH_SHOW")
End Function

Public Sub Disconnect1C()
  If Not V7 Is Nothing Then
    V7.ExecuteBatch ("ЗавершитьРаботуСистемы((0);")
    Set V7 = Nothing
  End If
End Sub

Public Function SumToText(MSum As Double) As String
If V7 Is Nothing Then
  If Not ConnectTo1C Then
    MsgBox "Связь с 1Ц не установлена!", vbCritical, "УФО+"
    Set V7 = Nothing
    SumToText = ""
    Exit Function
  End If
End If

'Рубли
V7.ExecuteBatch ("Пропись()")

'Доллары
'V7.ExecuteBatch ("Пропись(""USD.SPL"")")

SumToText = V7.EvalExpr("Формат(" & MSum & ", ""ЧПДС"")")

If Not V7 Is Nothing Then
  Disconnect1C
End If

End Function
...
Рейтинг: 0 / 0
25.09.2009, 21:14
| Ответить | Цитировать | Написать  
Сумма прописью
    #36218609
Nebo
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Nebo
Участник
Ещё одна сумма прописью, которую я использую, работает нормально:

Смотреть здесь: http://kuprava.narod.ru/rudn.htm

и здесь с исправленной ошибкой: http://kuprava.narod.ru/omiss_ex.htm
...
Рейтинг: 0 / 0
26.09.2009, 02:56
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Сумма прописью
    #36889763
Agaralex
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Agaralex
Гость
Можете ли подскажать почему у меня не работает ни один из скриптов... То ругается на "Имя?", то ругается на отстутствие необходимых библиотек при выполнении команд, например Str
...
Рейтинг: 0 / 0
08.10.2010, 15:50
| Ответить | Цитировать | Написать  
Сумма прописью
    #36889842
Фотография mds_world
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mds_world
Участник
AgaralexМожете ли подскажать почему у меня не работает ни один из скриптов... То ругается на "Имя?", то ругается на отстутствие необходимых библиотек при выполнении команд, например Str
Библиотеки. Наверняка. Зайдите в любом модуле в редактор ВБА. Далее меню-Tools-References. Ищите там среди библиотек с галочкой слово Missing. Снимите галочку с этой библиотеки
...
Рейтинг: 0 / 0
08.10.2010, 16:17
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Сумма прописью
    #37763525
ArtemKru
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ArtemKru
Гость
rokРекомендую!
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
Public Function TextSum(numSum As Variant) As String
w$ = Round(numSum, 2) 'Входное число - tekst tipа "123.45",защита
'"от дурака" не сделана
'выделение рублей в записи числа и удаление левых пробелов
rubli$ = LTrim$(Left$(Str(Val(w$) * 100), _
Len(Str(Val(w$) * 100)) - 2))
cop$ = RTrim$(Right$(Str(CDbl(w$) * 100), 2)) 'выделение дробной части
'числа и удаление правых пробелов

Do While Len(rubli$) < 9
rubli$ = "0" & rubli$
Loop
res$ = ""
For i% = 1 To 3
trojka$ = Mid$(rubli$, 3 * i% - 2, 3)
Call Num3(trojka$, i%) ' Вызов функции формирования gotovoй тройки,
'tipа "123 тысячи"
res$ = res$ & trojka$ ' Накопление таких троек
Next i%
'res$ = UCase$(Left$(res$, 1)) & Right$(res$, Len(res$) - 1) 'Запись
'первой буквы res$ в верхнем регистре

c$ = " коп." ' Блок добавления копеек
If (Right$(cop$, 1) = "1" And Left$(cop$, 1) <> "1") Then c$ = _
" коп."
If ((Right$(cop$, 1) = "2" Or Right$(cop$, 1) = "3" Or _
Right$(cop$, 1) = "4") And Left$(cop$, 1) <> "1") Then _
c$ = " коп."
If Left(res$, 1) <> "Р" Then res$ = res$ & cop$ & c$ Else _
res$ = cop$ & c$

TextSum = res$ ' Выход tekstа
End Function


Public Function Num3(trojka$, i%)
Dim sl$(1 To 3, 0 To 3)
sl$(1, 1) = "миллион "
sl$(2, 1) = "тысяча "
sl$(3, 1) = "рубль "
'-
sl$(1, 2) = "миллиона "
sl$(2, 2) = "тысячи "
sl$(3, 2) = "рубля "
'-
sl$(1, 3) = "миллионов "
sl$(2, 3) = "тысяч "
sl$(3, 3) = "рублей "
sl$(3, 0) = "рублей "
'-
ed$ = Right$(trojka$, 1)
des$ = Mid$(trojka$, 2, 1)
sot$ = Left$(trojka$, 1)
'-
If ed$ = "0" Then r3$ = ""
If ed$ = "1" Then If i% = 2 Then r3$ = "одна " Else r3$ = "один "
If ed$ = "2" Then If i% = 2 Then r3$ = "две " Else r3$ = "два "
If ed$ = "3" Then r3$ = "три "
If ed$ = "4" Then r3$ = "четыре "
If ed$ = "5" Then r3$ = "пять "
If ed$ = "6" Then r3$ = "шесть "
If ed$ = "7" Then r3$ = "семь "
If ed$ = "8" Then r3$ = "восемь "
If ed$ = "9" Then r3$ = "девять "
'-
If des$ = "0" Then r2$ = ""
s$ = des$ & ed$
If s$ = "10" Then r3$ = "десять "
If s$ = "11" Then r3$ = "одиннадцать "
If s$ = "12" Then r3$ = "двенадцать "
If s$ = "13" Then r3$ = "тринадцать "
If s$ = "14" Then r3$ = "четырнадцать "
If s$ = "15" Then r3$ = "пятнадцать "
If s$ = "16" Then r3$ = "шестнадцать "
If s$ = "17" Then r3$ = "семнадцать "
If s$ = "18" Then r3$ = "восемнадцать "
If s$ = "19" Then r3$ = "девятнадцать "
'-
If des$ = "2" Then r2$ = "двадцать "
If des$ = "3" Then r2$ = "тридцать "
If des$ = "4" Then r2$ = "сорок "
If des$ = "5" Then r2$ = "пятьдесят "
If des$ = "6" Then r2$ = "шестьдесят "
If des$ = "7" Then r2$ = "семьдесят "
If des$ = "8" Then r2$ = "восемьдесят "
If des$ = "9" Then r2$ = "девяносто "
'-
If sot$ = "0" Then r1$ = ""
If sot$ = "1" Then r1$ = "сто "
If sot$ = "2" Then r1$ = "двести "
If sot$ = "3" Then r1$ = "триста "
If sot$ = "4" Then r1$ = "четыреста "
If sot$ = "5" Then r1$ = "пятьсот "
If sot$ = "6" Then r1$ = "шестьсот "
If sot$ = "7" Then r1$ = "семьсот "
If sot$ = "8" Then r1$ = "восемьсот "
If sot$ = "9" Then r1$ = "девятьсот "
'-
If trojka$ <> "000" Then j% = (-1) * CInt(ed$ = "1" And des$ <> "1") _
+ (-2) * CInt((ed$ = "2" Or ed$ = "3" Or ed$ = "4") And des$ <> "1")
If j% = 0 And trojka$ <> "000" Then j% = 3
trojka$ = r1$ & r2$ & r3$ & sl$(i%, j%) 'формирование тройки цифр и
'слова,например-"123 тысячи"
End Function



Знающие люди подскажите как пользоваться этим макросом
...
Рейтинг: 0 / 0
20.04.2012, 16:39
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763554
ТвердолобыйЛамер
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ТвердолобыйЛамер
Участник
ArtemKruЗнающие люди подскажите как пользоваться этим макросом
Что совсем ни ни?
...
Рейтинг: 0 / 0
20.04.2012, 16:47
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763556
alvk
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk
Участник
ArtemKru,

Кем пользоваться??
...
Рейтинг: 0 / 0
20.04.2012, 16:48
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763559
ТвердолобыйЛамер
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ТвердолобыйЛамер
Участник
alvkКем пользоваться??
ЧЕМ
...
Рейтинг: 0 / 0
20.04.2012, 16:48
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763594
alvk
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk
Участник
ТвердолобыйЛамер,

- Абрамыч, вы в партию вступили?
- Ой, где?
...
Рейтинг: 0 / 0
20.04.2012, 16:59
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763705
212121
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
212121
Гость
ArtemKrurokРекомендую!
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
Public Function TextSum(numSum As Variant) As String
w$ = Round(numSum, 2) 'Входное число - tekst tipа "123.45",защита
'"от дурака" не сделана
'выделение рублей в записи числа и удаление левых пробелов
rubli$ = LTrim$(Left$(Str(Val(w$) * 100), _
Len(Str(Val(w$) * 100)) - 2))
cop$ = RTrim$(Right$(Str(CDbl(w$) * 100), 2)) 'выделение дробной части
'числа и удаление правых пробелов

Do While Len(rubli$) < 9
rubli$ = "0" & rubli$
Loop
res$ = ""
For i% = 1 To 3
trojka$ = Mid$(rubli$, 3 * i% - 2, 3)
Call Num3(trojka$, i%) ' Вызов функции формирования gotovoй тройки,
'tipа "123 тысячи"
res$ = res$ & trojka$ ' Накопление таких троек
Next i%
'res$ = UCase$(Left$(res$, 1)) & Right$(res$, Len(res$) - 1) 'Запись
'первой буквы res$ в верхнем регистре

c$ = " коп." ' Блок добавления копеек
If (Right$(cop$, 1) = "1" And Left$(cop$, 1) <> "1") Then c$ = _
" коп."
If ((Right$(cop$, 1) = "2" Or Right$(cop$, 1) = "3" Or _
Right$(cop$, 1) = "4") And Left$(cop$, 1) <> "1") Then _
c$ = " коп."
If Left(res$, 1) <> "Р" Then res$ = res$ & cop$ & c$ Else _
res$ = cop$ & c$

TextSum = res$ ' Выход tekstа
End Function


Public Function Num3(trojka$, i%)
Dim sl$(1 To 3, 0 To 3)
sl$(1, 1) = "миллион "
sl$(2, 1) = "тысяча "
sl$(3, 1) = "рубль "
'-
sl$(1, 2) = "миллиона "
sl$(2, 2) = "тысячи "
sl$(3, 2) = "рубля "
'-
sl$(1, 3) = "миллионов "
sl$(2, 3) = "тысяч "
sl$(3, 3) = "рублей "
sl$(3, 0) = "рублей "
'-
ed$ = Right$(trojka$, 1)
des$ = Mid$(trojka$, 2, 1)
sot$ = Left$(trojka$, 1)
'-
If ed$ = "0" Then r3$ = ""
If ed$ = "1" Then If i% = 2 Then r3$ = "одна " Else r3$ = "один "
If ed$ = "2" Then If i% = 2 Then r3$ = "две " Else r3$ = "два "
If ed$ = "3" Then r3$ = "три "
If ed$ = "4" Then r3$ = "четыре "
If ed$ = "5" Then r3$ = "пять "
If ed$ = "6" Then r3$ = "шесть "
If ed$ = "7" Then r3$ = "семь "
If ed$ = "8" Then r3$ = "восемь "
If ed$ = "9" Then r3$ = "девять "
'-
If des$ = "0" Then r2$ = ""
s$ = des$ & ed$
If s$ = "10" Then r3$ = "десять "
If s$ = "11" Then r3$ = "одиннадцать "
If s$ = "12" Then r3$ = "двенадцать "
If s$ = "13" Then r3$ = "тринадцать "
If s$ = "14" Then r3$ = "четырнадцать "
If s$ = "15" Then r3$ = "пятнадцать "
If s$ = "16" Then r3$ = "шестнадцать "
If s$ = "17" Then r3$ = "семнадцать "
If s$ = "18" Then r3$ = "восемнадцать "
If s$ = "19" Then r3$ = "девятнадцать "
'-
If des$ = "2" Then r2$ = "двадцать "
If des$ = "3" Then r2$ = "тридцать "
If des$ = "4" Then r2$ = "сорок "
If des$ = "5" Then r2$ = "пятьдесят "
If des$ = "6" Then r2$ = "шестьдесят "
If des$ = "7" Then r2$ = "семьдесят "
If des$ = "8" Then r2$ = "восемьдесят "
If des$ = "9" Then r2$ = "девяносто "
'-
If sot$ = "0" Then r1$ = ""
If sot$ = "1" Then r1$ = "сто "
If sot$ = "2" Then r1$ = "двести "
If sot$ = "3" Then r1$ = "триста "
If sot$ = "4" Then r1$ = "четыреста "
If sot$ = "5" Then r1$ = "пятьсот "
If sot$ = "6" Then r1$ = "шестьсот "
If sot$ = "7" Then r1$ = "семьсот "
If sot$ = "8" Then r1$ = "восемьсот "
If sot$ = "9" Then r1$ = "девятьсот "
'-
If trojka$ <> "000" Then j% = (-1) * CInt(ed$ = "1" And des$ <> "1") _
+ (-2) * CInt((ed$ = "2" Or ed$ = "3" Or ed$ = "4") And des$ <> "1")
If j% = 0 And trojka$ <> "000" Then j% = 3
trojka$ = r1$ & r2$ & r3$ & sl$(i%, j%) 'формирование тройки цифр и
'слова,например-"123 тысячи"
End Function



Знающие люди подскажите как пользоваться этим макросом
копируешь эту функцию в какой-нить модуль (закладка модули), затем
там где надо вызываешь её (типа:

Код: sql
1.
2.
3.
4.
Sub test1()
  sss = TextSum(12345.67)
  Debug.Print sss
End Sub
...
Рейтинг: 0 / 0
20.04.2012, 17:45
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763719
Фотография mds_world
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mds_world
Участник
Видимо, функция требуется в форме или отчете? Тогда в том поле, где должна быть сумма прописью, в ControlSource (свойство Данные поля) пишете
=TextSum([ЗдесьИмяПоляСуммы])
...
Рейтинг: 0 / 0
20.04.2012, 17:50
| Ответить | Цитировать | Написать  
Сумма прописью
    #37763727
Фотография mds_world
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mds_world
Участник
Ну и да, как уже сказано, функция должна быть в обычном модуле. Или в модуле той формы/отчета, в котором она вызывается.
...
Рейтинг: 0 / 0
20.04.2012, 17:52
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915538
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
че-то вот изобрелось на досуге, вдруг кому понравится:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
Public Function СуммаПрописью1(Сумма As String) As String
On Error GoTo Func_Err

Dim LowSumma, Rub As String * 12, i As Integer

If Len(Сумма) < 4 Or (Left(Right(Сумма, 3), 1) <> "-" And Left(Right(Сумма, 3), 1) <> "," And Left(Right(Сумма, 3), 1) <> ".") Then
    MsgBox "Неправильно введена сумма (нужно 0-00 или 0,00)"
    Exit Function
ElseIf Len(Сумма) = 4 And Left(Сумма, 1) = 0 Then
    LowSumma = "ноль "
End If
RSet Rub = Right(Left(Сумма, Len(Сумма) - 3), Len(Rub))
For i = 1 To 9
    Mid(Rub, i, 1) = IIf(Mid(Rub, i, 1) = " ", "0", Mid(Rub, i, 1))
Next

For i = Len(Rub) / 3 To 1 Step -1
    LowSumma = LowSumma & Сотни(Mid(Rub, Len(Rub) - i * 3 + 1, 3), i = 2)
    LowSumma = LowSumma & Razr(i, Mid(Rub, Len(Rub) - i * 3 + 1, 3))
Next
СуммаПрописью1 = UCase(Left(LowSumma, 1)) & Right(LowSumma, Len(LowSumma) - 1) & Right(Сумма, 2) & Razr(0, Right(Сумма, 2))

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Сотни(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Сотни = Десятки(Right(str, Len(str) - 1), bool)
Case 1
    Сотни = "сто " & Десятки(Right(str, 2), bool)
Case 2
    Сотни = "двести " & Десятки(Right(str, 2), bool)
Case 3
   Сотни = "триста " & Десятки(Right(str, 2), bool)
Case 4
   Сотни = "четыреста " & Десятки(Right(str, 2), bool)
Case 5
    Сотни = "пятьсот " & Десятки(Right(str, 2), bool)
Case 6
    Сотни = "шестьсот " & Десятки(Right(str, 2), bool)
Case 7
    Сотни = "семьсот " & Десятки(Right(str, 2), bool)
Case 8
    Сотни = "восемьсот " & Десятки(Right(str, 2), bool)
Case 9
    Сотни = "девятьсот " & Десятки(Right(str, 2), bool)
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Public Function Десятки(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Десятки = Единицы(Right(str, Len(str) - 1), bool)
Case 1
    Select Case Mid(str, 2, 1)
    Case 0
        Десятки = "десять "
    Case 1
        Десятки = "одиннадцать "
    Case 2
        Десятки = "двенадцать "
    Case 3
        Десятки = "тринадцать "
    Case 4
        Десятки = "четырнадцать "
    Case 5
        Десятки = "пятнадцать "
    Case 6
        Десятки = "шестнадцать "
    Case 7
        Десятки = "семнадцать "
    Case 8
        Десятки = "восемнадцать "
    Case 9
        Десятки = "девятнадцать "
    End Select
Case 2
    Десятки = "двадцать " & Единицы(Right(str, 1), bool)
Case 3
    Десятки = "тридцать " & Единицы(Right(str, 1), bool)
Case 4
    Десятки = "сорок " & Единицы(Right(str, 1), bool)
Case 5
    Десятки = "пятьдесят " & Единицы(Right(str, 1), bool)
Case 6
    Десятки = "шестьдесят " & Единицы(Right(str, 1), bool)
Case 7
    Десятки = "семьдесят " & Единицы(Right(str, 1), bool)
Case 8
    Десятки = "восемьдесят " & Единицы(Right(str, 1), bool)
Case 9
    Десятки = "девяносто " & Единицы(Right(str, 1), bool)
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Единицы(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Единицы = ""
Case 1
    Единицы = IIf(bool, "одна ", "один ")
Case 2
    Единицы = IIf(bool, "две ", "два ")
Case 3
    Единицы = "три "
Case 4
    Единицы = "четыре "
Case 5
    Единицы = "пять "
Case 6
    Единицы = "шесть "
Case 7
    Единицы = "семь "
Case 8
    Единицы = "восемь "
Case 9
    Единицы = "девять "
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Razr(i As Integer, str As String) As String
On Error GoTo Func_Err

Select Case i
Case 0
    Razr = IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, " копейка ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), " копейки ", " копеек ")), " копеек ")
Case 1
    Razr = IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "рубль ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "рубля ", "рублей ")), "рублей ")
Case 2
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "тысяча ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "тысячи ", "тысяч ")), "тысяч "))
Case 3
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "миллион ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "миллиона ", "миллионов ")), "миллионов "))
Case 4
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "миллиард ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "миллиарда ", "миллиардов ")), "миллиардов "))
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function
...
Рейтинг: 0 / 0
14.08.2012, 10:51
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915542
Фотография Программист-Любитель
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Программист-Любитель
Участник
Вы на это тратили свое время, когда в гугле кучи разных сумм прописью ?
...
Рейтинг: 0 / 0
14.08.2012, 10:53
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915674
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
Программист-ЛюбительВы на это тратили свое время, когда в гугле кучи разных сумм прописью ?

ну я просмотрела кучку, почему-то не глянулись они мне)
захотелось самой изобрести...
бывает такое.
...
Рейтинг: 0 / 0
14.08.2012, 12:18
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915706
alvk
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk
Участник
Программист-ЛюбительВы на это тратили свое время, когда в гугле кучи разных сумм прописью ?

+1
Тоже никогда не пойму автора, я две штуки из этой темы у себя использую и проблем не знаю.
...
Рейтинг: 0 / 0
14.08.2012, 12:42
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915792
DarkMan
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
DarkMan
Участник
alvkТоже никогда не пойму автора,
Может человек для общего развития, так сказать повышения квалификации. Почему бы и нет?
Приятно посмотреть на полоды своего труда.
Вас же никто не заставляет использовать ее наработки,а не чьи нибудь другие.
...
Рейтинг: 0 / 0
14.08.2012, 13:36
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915797
непоймучка
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
непоймучка
Гость
mousecче-то вот изобрелось на досуге, вдруг кому понравитсяврет при <100
Код: vbnet
1.
2.
?СуммаПрописью1("10,00")
Рублей 00 копеек
...
Рейтинг: 0 / 0
14.08.2012, 13:39
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915851
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
непоймучкаmousecче-то вот изобрелось на досуге, вдруг кому понравитсяврет при <100
Код: vbnet
1.
2.
?СуммаПрописью1("10,00")
Рублей 00 копеек



спасибо огромное за тест, исправила:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
Public Function СуммаПрописью1(Сумма As String) As String
On Error GoTo Func_Err

Dim LowSumma, Rub As String * 12, i As Integer

If Len(Сумма) < 4 Or (Left(Right(Сумма, 3), 1) <> "-" And Left(Right(Сумма, 3), 1) <> "," And Left(Right(Сумма, 3), 1) <> ".") Then
    MsgBox "Неправильно введена сумма (нужно 0-00 или 0,00)"
    Exit Function
ElseIf Len(Сумма) = 4 And Left(Сумма, 1) = 0 Then
    LowSumma = "ноль "
End If
RSet Rub = Right(Left(Сумма, Len(Сумма) - 3), Len(Rub))
For i = 1 To Len(Rub)
    Mid(Rub, i, 1) = IIf(Mid(Rub, i, 1) = " ", "0", Mid(Rub, i, 1))
Next

For i = Len(Rub) / 3 To 1 Step -1
    LowSumma = LowSumma & Сотни(Mid(Rub, Len(Rub) - i * 3 + 1, 3), i = 2)
    LowSumma = LowSumma & Razr(i, Mid(Rub, Len(Rub) - i * 3 + 1, 3))
Next
СуммаПрописью1 = UCase(Left(LowSumma, 1)) & Right(LowSumma, Len(LowSumma) - 1) & Right(Сумма, 2) & Razr(0, Right(Сумма, 2))

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Сотни(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Сотни = Десятки(Right(str, Len(str) - 1), bool)
Case 1
    Сотни = "сто " & Десятки(Right(str, 2), bool)
Case 2
    Сотни = "двести " & Десятки(Right(str, 2), bool)
Case 3
   Сотни = "триста " & Десятки(Right(str, 2), bool)
Case 4
   Сотни = "четыреста " & Десятки(Right(str, 2), bool)
Case 5
    Сотни = "пятьсот " & Десятки(Right(str, 2), bool)
Case 6
    Сотни = "шестьсот " & Десятки(Right(str, 2), bool)
Case 7
    Сотни = "семьсот " & Десятки(Right(str, 2), bool)
Case 8
    Сотни = "восемьсот " & Десятки(Right(str, 2), bool)
Case 9
    Сотни = "девятьсот " & Десятки(Right(str, 2), bool)
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Десятки(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Десятки = Единицы(Right(str, Len(str) - 1), bool)
Case 1
    Select Case Mid(str, 2, 1)
    Case 0
        Десятки = "десять "
    Case 1
        Десятки = "одиннадцать "
    Case 2
        Десятки = "двенадцать "
    Case 3
        Десятки = "тринадцать "
    Case 4
        Десятки = "четырнадцать "
    Case 5
        Десятки = "пятнадцать "
    Case 6
        Десятки = "шестнадцать "
    Case 7
        Десятки = "семнадцать "
    Case 8
        Десятки = "восемнадцать "
    Case 9
        Десятки = "девятнадцать "
    End Select
Case 2
    Десятки = "двадцать " & Единицы(Right(str, 1), bool)
Case 3
    Десятки = "тридцать " & Единицы(Right(str, 1), bool)
Case 4
    Десятки = "сорок " & Единицы(Right(str, 1), bool)
Case 5
    Десятки = "пятьдесят " & Единицы(Right(str, 1), bool)
Case 6
    Десятки = "шестьдесят " & Единицы(Right(str, 1), bool)
Case 7
    Десятки = "семьдесят " & Единицы(Right(str, 1), bool)
Case 8
    Десятки = "восемьдесят " & Единицы(Right(str, 1), bool)
Case 9
    Десятки = "девяносто " & Единицы(Right(str, 1), bool)
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Единицы(str As String, Optional bool As Boolean) As String
On Error GoTo Func_Err

Select Case Left(str, 1)
Case 0
    Единицы = ""
Case 1
    Единицы = IIf(bool, "одна ", "один ")
Case 2
    Единицы = IIf(bool, "две ", "два ")
Case 3
    Единицы = "три "
Case 4
    Единицы = "четыре "
Case 5
    Единицы = "пять "
Case 6
    Единицы = "шесть "
Case 7
    Единицы = "семь "
Case 8
    Единицы = "восемь "
Case 9
    Единицы = "девять "
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function

Function Razr(i As Integer, str As String) As String
On Error GoTo Func_Err

Select Case i
Case 0
    Razr = IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, " копейка ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), " копейки ", " копеек ")), " копеек ")
Case 1
    Razr = IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "рубль ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "рубля ", "рублей ")), "рублей ")
Case 2
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "тысяча ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "тысячи ", "тысяч ")), "тысяч "))
Case 3
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "миллион ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "миллиона ", "миллионов ")), "миллионов "))
Case 4
    Razr = IIf(CInt(Left(str, 3)) = 0, "", IIf(Left(Right(str, 2), 1) <> 1, IIf(Right(str, 1) = 1, "миллиард ", IIf(((Right(str, 1) = 2) Or (Right(str, 1) = 3) Or (Right(str, 1) = 4)), "миллиарда ", "миллиардов ")), "миллиардов "))
End Select

Func_Exit:
    Exit Function
Func_Err:
    MsgBox Err.Description
    Resume Next
End Function



всем остальным мастера гугла и поиска - рада за вас.
...
Рейтинг: 0 / 0
14.08.2012, 14:05
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915869
DarkMan
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
DarkMan
Участник
mousecспасибо огромное за тест, исправила:
Теперь вроде как работает.
mousecвсем остальным мастера гугла и поиска - рада за вас.
Девушка не обращайте внимания. Они женоненавистники.
...
Рейтинг: 0 / 0
14.08.2012, 14:12
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915958
studieren
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
studieren
Участник
mousec,

:-)
Код: sql
1.
2.
3.
4.
?СуммаПрописью1("9999-01")
Девять тысяч девятьсот девяносто девять рублей 01 копейка 
СуммаПрописью1("9 999-01")
Девяносто тысяч девятьсот девяносто девять рублей 01 копейка
...
Рейтинг: 0 / 0
14.08.2012, 14:42
| Ответить | Цитировать | Написать  
Сумма прописью
    #37915987
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
Вот написал бы кто универсальную функцию, которая годится для десятков языков...
...
Рейтинг: 0 / 0
14.08.2012, 14:52
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916002
Фотография ILL HEAD
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
ILL HEAD
Участник
Владимир Саныч,

translate.google.com
всем функциям функция
...
Рейтинг: 0 / 0
14.08.2012, 14:56
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916011
studieren
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
studieren
Участник
mousec,

Зря Вы в качестве параметра функции взяли строку, а не число.
Вот посудите сами что из этого вышло:
Код: vbnet
1.
2.
3.
4.
?СуммаПрописью1("1?1-01")
Сто рубль 01 копейка 
?СуммаПрописью1("10E11-AA")
Десять тысяч рублей AA копеек
...
Рейтинг: 0 / 0
14.08.2012, 14:58
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916060
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
))) ну эти-то ошибки я знаю)
точнее сказать - недочеты)
при использовании этого модулька принимается в кач-ве н.у., что в качестве исходной строки передается результат неких вычислений, то есть НЕцифр там быть не может, кроме разделителя.
единственная защита от дурака там стоит только на тип разделителя. если разделителя вообще нет на своем месте - сообщение об ошибке.
поясню - вызывается эта функция из таких форм, как счет-фактура, счет, акт и расчет ОСАГО - расчет стоимости производится программно. единственное, что они мне пару раз учудили, было "а можно я вот тут вручную копеечки подправлю, а то у меня сдачи нету!..." после чего пропал разделитель или копеек стало три знака, или в разделитель зафигачили звездочку....
вопщем, как-то так.
...
Рейтинг: 0 / 0
14.08.2012, 15:13
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916064
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
странный форум - а свои сообщения редактировать нельзя или мне не по глазам кнопочка?
...
Рейтинг: 0 / 0
14.08.2012, 15:14
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916198
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
mousecстранный форум - а свои сообщения редактировать нельзя или мне не по глазам кнопочка?
Низя.
...
Рейтинг: 0 / 0
14.08.2012, 15:56
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916364
alvk
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk
Участник
mousecвсем остальным мастера гугла и поиска - рада за вас.

я лично эту фразу не понял. перевод на русский будет?
...
Рейтинг: 0 / 0
14.08.2012, 17:08
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916555
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
alvkmousecвсем остальным мастера гугла и поиска - рада за вас.
я лично эту фразу не понял. перевод на русский будет?
Там опечатка. Должно быть мастераМ. "Сообщаю мастерам поиска, что рада за вас".
...
Рейтинг: 0 / 0
14.08.2012, 18:42
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916592
Поправка:
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Поправка:
Гость
Владимир Санычalvkпропущено...

я лично эту фразу не понял. перевод на русский будет?
Там опечатка. Должно быть мастераМ. "Сообщаю мастерам поиска, что рада за вас".
Там жоще: обращение, выделяемое занятыми :-)
...
Рейтинг: 0 / 0
14.08.2012, 19:12
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916661
mousec
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
mousec
Гость
Поправка:Владимир Санычпропущено...

Там опечатка. Должно быть мастераМ. "Сообщаю мастерам поиска, что рада за вас".
Там жоще: обращение, выделяемое занятыми :-)

нет, там была именно опечатка - нехватка буквы М.
то не выделенного запятыми обращения я еще, надеюсь, не дожила.
...
Рейтинг: 0 / 0
14.08.2012, 20:40
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916837
alvk
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk
Участник
Владимир Санычalvkпропущено...

я лично эту фразу не понял. перевод на русский будет?
Там опечатка. Должно быть мастераМ. "Сообщаю мастерам поиска, что рада за вас".

спасибо за перевод, а то голову ломал.
mousecто не выделенного запятыми обращения я еще, надеюсь, не дожила.

вас с каждой фразой всё труднее и труднее понимать. то = до ??
...
Рейтинг: 0 / 0
15.08.2012, 03:35
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916841
С русского на русский
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
С русского на русский
Гость
alvk,

да
...
Рейтинг: 0 / 0
15.08.2012, 03:58
| Ответить | Цитировать | Написать  
Сумма прописью
    #37916991
abend
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
abend
Гость
Добавлю в копилку функцию, которая возвращает сумму прописью (сумма должна быть меньше миллиона, но руками можно и дописать при необходимости) на трех языках: русском, украинском и английском для валют: рубли, гривны, USD, Евро

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
Function textSum(ByVal numAmount As Variant, _
                    Optional ByVal currencyId As Integer = 643, _
                    Optional ByVal curLang As String = "RU") As String

    Dim StrIntSumma As String, spellNumber As String, strKop As String
    Dim KolRazr As Byte, TekRazr As Byte, tekNum As Byte
    Dim curMale As Boolean, notNullAmount As Boolean
     
     
    If Not IsNumeric(numAmount) Then Exit Function
    If numAmount >= 10 ^ 9 Then Exit Function
    If curLang <> "RU" And curLang <> "EN" And curLang <> "UA" Then Exit Function
     
    curMale = Not (currencyId = 980)
     
    StrIntSumma = CStr(Int(Abs(numAmount)))
    KolRazr = Len(StrIntSumma)
    TekRazr = KolRazr
    
    strKop = Format$((Abs(Round(numAmount, 2)) - Int(Abs(numAmount))) * 100, "00")
     
    While TekRazr > 0
        
        If TekRazr = 9 Or TekRazr = 6 Then notNullAmount = False
        
        tekNum = Mid(StrIntSumma, KolRazr + 1 - TekRazr, 1)
        
        If TekRazr = 1 Or TekRazr = 4 Or TekRazr = 7 Then
            If KolRazr > TekRazr Then
                If Mid$(StrIntSumma, KolRazr - TekRazr, 1) = "1" Then
                    tekNum = 0
                End If
            End If
        End If
        
        If (TekRazr = 2 Or TekRazr = 5 Or TekRazr = 8) And tekNum = 1 Then
            tekNum = Mid(StrIntSumma, KolRazr + 1 - TekRazr, 2)
        End If
        
        If tekNum <> 0 Then
            
            notNullAmount = True
            
            If TekRazr = 3 Or TekRazr = 6 Or TekRazr = 9 Then
                
                Select Case curLang
                    Case "RU"
                        spellNumber = spellNumber & " " & Choose(tekNum, _
                                        "сто", _
                                        "двести", _
                                        "триста", _
                                        "четыреста", _
                                        "пятьсот", _
                                        "шестьсот", _
                                        "семьсот", _
                                        "восемьсот", _
                                        "девятьсот")
                    Case "UA"
                        spellNumber = spellNumber & " " & Choose(tekNum, _
                                        "сто", _
                                        "двісті", _
                                        "триста", _
                                        "чотириста", _
                                        "п'ятсот", _
                                        "шістсот", _
                                        "сімсот", _
                                        "вісімсот", _
                                        "дев'ятсот")
                    Case "EN"
                        spellNumber = spellNumber & " " & Choose(tekNum, _
                                        "one", _
                                        "two", _
                                        "three", _
                                        "four", _
                                        "five", _
                                        "six", _
                                        "seven", _
                                        "eight", _
                                        "nine") & " hundred"
                        If Mid$(StrIntSumma, KolRazr + 2 - TekRazr, 2) <> "00" Then
                            spellNumber = spellNumber & " and"
                        End If
                    Case Else
                        spellNumber = spellNumber & " ???"
                End Select
            
            ElseIf (TekRazr = 2 Or TekRazr = 5 Or TekRazr = 8) And tekNum < 10 Then
            
                If curLang = "RU" Then
                    spellNumber = spellNumber & " " & Choose(tekNum - 1, _
                                    "двадцать", _
                                    "тридцать", _
                                    "сорок", _
                                    "пятьдесят", _
                                    "шестьдесят", _
                                    "семьдесят", _
                                    "восемьдесят", _
                                    "девяносто" _
                                    )
                ElseIf curLang = "UA" Then
                    spellNumber = spellNumber & " " & Choose(tekNum - 1, _
                                    "двадцять", _
                                    "тридцять", _
                                    "сорок", _
                                    "п'ятдесят", _
                                    "шістдесят", _
                                    "сімдесят", _
                                    "вісімдесят", _
                                    "дев'яносто" _
                                    )
                Else
                    spellNumber = spellNumber & " " & Choose(tekNum, _
                                    "twenty", _
                                    "thirty", _
                                    "fourty", _
                                    "fifty", _
                                    "sixty", _
                                    "seventy", _
                                    "eighty", _
                                    "ninety" _
                                    )
                End If
            
            Else
       
                Select Case tekNum
                    
                    Case 1
                        
                        If TekRazr = 7 Or (TekRazr = 1 And curMale) Then
                            If curLang = "UA" Or curLang = "RU" Then
                                spellNumber = spellNumber & " один"
                            Else
                                spellNumber = spellNumber & " one"
                            End If
                        Else
                            If curLang = "UA" Or curLang = "RU" Then
                                spellNumber = spellNumber & " одна"
                            Else
                                spellNumber = spellNumber & " one"
                            End If
                        End If
                        
                    Case 2
                        
                        If TekRazr = 7 Or (TekRazr = 1 And curMale) Then
                            If curLang = "UA" Or curLang = "RU" Then
                                spellNumber = spellNumber & " два"
                            Else
                                spellNumber = spellNumber & " two"
                            End If
                        Else
                            If curLang = "RU" Then
                                spellNumber = spellNumber & " две"
                            ElseIf curLang = "UA" Then
                                spellNumber = spellNumber & " двi"
                            Else
                                spellNumber = spellNumber & " two"
                            End If
                        End If
                        
                    Case Else
                        
                        If curLang = "RU" Then
                            spellNumber = spellNumber & " " & Choose(tekNum - 2, _
                                            "три", _
                                            "четыре", _
                                            "пять", _
                                            "шесть", _
                                            "семь", _
                                            "восемь", _
                                            "девять", _
                                            "десять", _
                                            "одиннадцать", _
                                            "двенадцать", _
                                            "тринадцать", _
                                            "четырнадцать", _
                                            "пятнадцать", _
                                            "шестнадцать", _
                                            "семнадцать", _
                                            "восемнадцать", _
                                            "девятнадцать" _
                                            )
                        ElseIf curLang = "UA" Then
                            spellNumber = spellNumber & " " & Choose(tekNum - 2, _
                                            "три", _
                                            "чотири", _
                                            "п'ять", _
                                            "шість", _
                                            "сім", _
                                            "вісім", _
                                            "дев'ять", _
                                            "десять", _
                                            "одинадцять", _
                                            "дванадцять", _
                                            "тринадцять", _
                                            "чотирнадцять", _
                                            "п'ятнадцять", _
                                            "шістнадцять", _
                                            "сімнадцять", _
                                            "вісімнадцять", _
                                            "дев'ятнадцять" _
                                            )
                        Else
                            spellNumber = spellNumber & " " & Choose(tekNum - 2, _
                                            "three", _
                                            "four", _
                                            "five", _
                                            "six", _
                                            "seven", _
                                            "eight", _
                                            "nine", _
                                            "ten", _
                                            "eleven", _
                                            "twelve", _
                                            "thirteen", _
                                            "fourteen", _
                                            "fifteen", _
                                            "sixteen", _
                                            "seventeen", _
                                            "eighteen", _
                                            "nineteen" _
                                            )
                        End If
                    
                End Select
            
            End If
        
        End If
       
        If TekRazr = 7 And notNullAmount Then
            
            Select Case tekNum
                Case 1
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " миллион"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " мільйон"
                    Else
                        spellNumber = spellNumber & " million"
                    End If
                Case 2, 3, 4
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " миллиона"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " мільйони"
                    Else
                        spellNumber = spellNumber & " million"
                    End If
                Case Else
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " миллионов"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " мільйонів"
                    Else
                        spellNumber = spellNumber & " million"
                    End If
            End Select
        
        ElseIf TekRazr = 4 And notNullAmount Then
            
            Select Case tekNum
                Case 1
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " тысяча"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " тисяча"
                    Else
                        spellNumber = spellNumber & " thousand"
                    End If
                Case 2, 3, 4
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " тысячи"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " тисячі"
                    Else
                        spellNumber = spellNumber & " thousand"
                    End If
                Case Else
                    If curLang = "RU" Then
                        spellNumber = spellNumber & " тысяч"
                    ElseIf curLang = "UA" Then
                        spellNumber = spellNumber & " тисяч"
                    Else
                        spellNumber = spellNumber & " thousand"
                    End If
            End Select
        
        End If
            
        TekRazr = TekRazr - 1
    
    Wend
    
    If Len(spellNumber) = 0 Then
        If curLang = "RU" Then
            spellNumber = spellNumber & " ноль"
        ElseIf curLang = "UA" Then
            spellNumber = spellNumber & " нуль"
        Else
            spellNumber = spellNumber & " zero"
        End If
    End If
    
    If Sgn(numAmount) = -1 Then
        If curLang = "RU" Then
            spellNumber = "минус" & spellNumber
        ElseIf curLang = "UA" Then
            spellNumber = "мінус" & spellNumber
        Else
            spellNumber = "minus" & spellNumber
        End If
    End If
    
    Select Case currencyId
        Case 643
            If curLang = "RU" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " рубль"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " рубля"
                    Case Else
                        spellNumber = spellNumber & " рублей"
                End Select
                spellNumber = spellNumber & " " & strKop & " коп."
            ElseIf curLang = "UA" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " рубль"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " рублi"
                    Case Else
                        spellNumber = spellNumber & " рублiв"
                End Select
                spellNumber = spellNumber & " " & strKop & " коп."
            Else
                spellNumber = spellNumber & " RUR"
                spellNumber = spellNumber & " " & strKop & " kop."
            End If
        Case 980
            If curLang = "RU" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " гривна"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " гривны"
                    Case Else
                        spellNumber = spellNumber & " гривен"
                End Select
                spellNumber = spellNumber & " " & strKop & " коп."
            ElseIf curLang = "UA" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " гривня"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " гривні"
                    Case Else
                        spellNumber = spellNumber & " гривень"
                End Select
                spellNumber = spellNumber & " " & strKop & " коп."
            Else
                spellNumber = spellNumber & " UAH"
                spellNumber = spellNumber & " " & strKop & " kop."
            End If
        Case 840
            If curLang = "RU" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " доллар США"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " доллара США"
                    Case Else
                        spellNumber = spellNumber & " долларов США"
                End Select
                spellNumber = spellNumber & " " & strKop & " центов"
            ElseIf curLang = "UA" Then
                Select Case tekNum
                    Case 1
                        spellNumber = spellNumber & " долар США"
                    Case 2, 3, 4
                        spellNumber = spellNumber & " долари США"
                    Case Else
                        spellNumber = spellNumber & " доларiв США"
                End Select
                spellNumber = spellNumber & " " & strKop & " центів"
            Else
                spellNumber = spellNumber & " USD"
                spellNumber = spellNumber & " " & strKop & " cents"
            End If
        Case 978
            If curLang = "RU" Then
                spellNumber = spellNumber & " Евро"
                spellNumber = spellNumber & " " & strKop & " евроцентов"
            ElseIf curLang = "UA" Then
                spellNumber = spellNumber & " Євро"
                spellNumber = spellNumber & " " & strKop & " євроцентів"
            Else
                spellNumber = spellNumber & " EUR"
                spellNumber = spellNumber & " " & strKop & " eurocents"
            End If
        Case Else
            spellNumber = spellNumber & ","
    End Select
    
    spellNumber = Trim$(spellNumber)
    spellNumber = UCase(Mid$(spellNumber, 1, 1)) & Mid$(spellNumber, 2)
    
    textSum = spellNumber
    
    
End Function
...
Рейтинг: 0 / 0
15.08.2012, 09:42
| Ответить | Цитировать | Написать  
Сумма прописью
    #37968818
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
В форме базы данных есть два окошка, первое - это Список149, в нем отображается результат суммы, взятый из запроса. В Поле140 отображается сумма прописью. Обработка перевода в пропись естественно в модуле. Так вот при открывание формы в Поле140 перевод в пропись не появляется и возникает там только при нажатие мышкой на Список149. В чем проблема? Пишу под себя и сложно сразу разобраться во всех нюансах программирования.


Private Sub Список149_BeforeUpdate(Cancel As Integer)
Me.Поле140 = propiskop(Me.Список149)
Me.Поле140.Requery
End Sub
...
Рейтинг: 0 / 0
23.09.2012, 16:56
| Ответить | Цитировать | Написать  
Сумма прописью
    #37969349
Фотография NickBell
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
NickBell
Участник
serbar62,

Для автоматического отображения суммы прописью, в ContolSource поля надо записать

=НазваниеФункции(Аргумент)

=propiskop(Список149)

С названиями ваших полей немного сложно разобраться, надеюсь, угадала.

Появление текста суммы прописью
...
Рейтинг: 0 / 0
24.09.2012, 09:28
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970030
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Спасибо за участие в горе моем. Но не работает. На картинке есть результат работы. Есть еще мысли? Или я где-то наглючил?
...
Рейтинг: 0 / 0
24.09.2012, 15:05
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970065
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Исследования проблемы привели в модуль перевода в пропись. Показал на картинке.
...
Рейтинг: 0 / 0
24.09.2012, 15:24
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970152
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
serbar62Исследования проблемы привели в модуль перевода в пропись. Показал на картинке.
Чему у Вас равно N? Вы пытаетесь перевести в пропись пустое значение?
...
Рейтинг: 0 / 0
24.09.2012, 16:17
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970312
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Если честно, то алгоритм сильно не копал и не боролся с ним. Взята заготовка с инета. Нажатием кнопки на поле все работает нормально. Вот сам текст алгоритма:
 
Код: vbnet
1.
2.


Option Compare Database

'пример использования

Sub FDGSFG()

Debug.Print propiskop(12536.25)

End Sub


'
'ИСПОЛЬЗОВАТЬ ЭТУ ФУНКЦИЮ!!!
'

Function propiskop(num)
' Аргументы: положительное число < 1 000 000 000 000,457
' Назначение: преобразует это число в число прописью (с рублями и с копейками)
' Возвращает: строку, содержащую число прописью
' например propiskop(3000119,472) -> три миллиона сто девятнадцать рублей 47 копеек
' Вызывает: функции prop3(), prop3t(), prop3rub() и propkop()
' Вызов: propiskop()
' Составил: 4.07.96г., дописаны копейки 12.01.98г.

N = Int(((num - Int(num)) * 100) + 0.5) ' выделить копейки с правильным округлением
S = propkop(N) ' преобразовать копейки
N = Int(num) ' выделить рубли
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число
S = prop3rub(M) + S ' преобразовать младшие три цифры и приписать рублей/рубля/рубль
N = Int(num / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число тысяч
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "тысяча "
Case 2 To 4
L = "тысячи "
Case Else
L = "тысяч "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "тысяч "
End Select
S = prop3t(M) + L + S ' вызов prop3t для преобразования тысяч
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллион "
Case 2 To 4
L = "миллиона "
Case Else
L = "миллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллионов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллиардов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллиард "
Case 2 To 4
L = "миллиарда "
Case Else
L = "миллиардов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллиардов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллиардов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число триллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "триллион "
Case 2 To 4
L = "триллиона "
Case Else
L = "триллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "триллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования триллионов
End If
S = UCase(Mid(S, 1, 1)) + Mid(S, 2) ' первую букву сделать заглавной
propiskop = S

End Function



Function prop3(N)
' Аргументы: трехзначное целое положительное число
' Назначение: преобразует это число в число прописью
' Возвращает: строку, содержащую число прописью
' например prop3(119) -> сто девятнадцать
' Вызов: из функции propis()
' Составил: 2.07.96г.

S = ""
Select Case (N - 100 * Int(N / 100)) ' выделить две последние цифры
Case 10
S = "десять "
Case 11
S = "одинадцать "
Case 12
S = "двенадцать "
Case 13
S = "тринадцать "
Case 14
S = "четырнадцать "
Case 15
S = "пятнадцать "
Case 16
S = "шестнадцать "
Case 17
S = "семнадцать "
Case 18
S = "восемнадцать "
Case 19
S = "девятнадцать "
Case Else
i = 10 * Int(N / 10)
Select Case (N - i) ' выделить цифру единицы
Case 1
S = "один "
Case 2
S = "два "
Case 3
S = "три "
Case 4
S = "четыре "
Case 5
S = "пять "
Case 6
S = "шесть "
Case 7
S = "семь "
Case 8
S = "восемь "
Case 9
S = "девять "
End Select
SS = ""
i = i / 10
Select Case (i - 10 * Int(i / 10)) ' выделить цифру десятков
Case 2
SS = "двадцать "
Case 3
SS = "тридцать "
Case 4
SS = "сорок "
Case 5
SS = "пятьдесят "
Case 6
SS = "шестьдесят "
Case 7
SS = "семьдесят "
Case 8
SS = "восемьдесят "
Case 9
SS = "девяносто "
End Select
S = SS + S
End Select
SS = ""
Select Case Int(N / 100) ' выделить цифру сотен
Case 1
SS = "сто "
Case 2
SS = "двести "
Case 3
SS = "триста "
Case 4
SS = "четыреста "
Case 5
SS = "пятьсот "
Case 6
SS = "шестьсот "
Case 7
SS = "семьсот "
Case 8
SS = "восемьсот "
Case 9
SS = "девятьсот "
End Select
S = SS + S
prop3 = S
End Function

Function prop3rub(N)
' Аргументы: трехзначное целое положительное число
' Назначение: преобразует это число в число прописью с допиской рублей/рубля/рубль
' Возвращает: строку, содержащую число прописью
' например prop3rub(132) -> сто тридцать два рубля
' Вызов: из функции propis()
' Составил: 8.01.98г.

S = ""
Rub = "гривен "
Select Case (N - 100 * Int(N / 100)) ' выделить две последние цифры
Case 10
S = "десять " + Rub
Case 11
S = "одинадцать " + Rub
Case 12
S = "двенадцать " + Rub
Case 13
S = "тринадцать " + Rub
Case 14
S = "четырнадцать " + Rub
Case 15
S = "пятнадцать " + Rub
Case 16
S = "шестнадцать " + Rub
Case 17
S = "семнадцать " + Rub
Case 18
S = "восемнадцать " + Rub
Case 19
S = "девятнадцать " + Rub
Case Else
i = 10 * Int(N / 10)
Select Case (N - i) ' выделить цифру единицы
Case 0
S = Rub
Case 1
S = "одна гривна "
Case 2
S = "две гривны "
Case 3
S = "три гривны "
Case 4
S = "четыре гривны "
Case 5
S = "пять " + Rub
Case 6
S = "шесть " + Rub
Case 7
S = "семь " + Rub
Case 8
S = "восемь " + Rub
Case 9
S = "девять " + Rub
End Select
SS = ""
i = i / 10
Select Case (i - 10 * Int(i / 10)) ' выделить цифру десятков
Case 2
SS = "двадцать "
Case 3
SS = "тридцать "
Case 4
SS = "сорок "
Case 5
SS = "пятьдесят "
Case 6
SS = "шестьдесят "
Case 7
SS = "семьдесят "
Case 8
SS = "восемьдесят "
Case 9
SS = "девяносто "
End Select
S = SS + S
End Select
SS = ""
Select Case Int(N / 100) ' выделить цифру сотен
Case 1
SS = "сто "
Case 2
SS = "двести "
Case 3
SS = "триста "
Case 4
SS = "четыреста "
Case 5
SS = "пятьсот "
Case 6
SS = "шестьсот "
Case 7
SS = "семьсот "
Case 8
SS = "восемьсот "
Case 9
SS = "девятьсот "
End Select
S = SS + S
prop3rub = S

End Function

Function prop3t(N)
' Аргументы: трехзначное целое положительное число
' Назначение: преобразует это число в число прописью
' Возвращает: строку, содержащую число прописью
' например prop3е(101) -> сто одна (тысяча)
' например prop3е(102) -> сто две (тысячи)
' Вызов: из функции propis() для тысяч
' Составил: 2.07.96г.

S = ""
Select Case (N - 100 * Int(N / 100)) ' выделить две последние цифры
Case 10
S = "десять "
Case 11
S = "одинадцать "
Case 12
S = "двенадцать "
Case 13
S = "тринадцать "
Case 14
S = "четырнадцать "
Case 15
S = "пятнадцать "
Case 16
S = "шестнадцать "
Case 17
S = "семнадцать "
Case 18
S = "восемнадцать "
Case 19
S = "девятнадцать "
Case Else
i = 10 * Int(N / 10)
Select Case (N - i) ' выделить цифру единицы
Case 1
S = "одна "
Case 2
S = "две "
Case 3
S = "три "
Case 4
S = "четыре "
Case 5
S = "пять "
Case 6
S = "шесть "
Case 7
S = "семь "
Case 8
S = "восемь "
Case 9
S = "девять "
End Select
SS = ""
i = i / 10
Select Case (i - 10 * Int(i / 10)) ' выделить цифру десятков
Case 2
SS = "двадцать "
Case 3
SS = "тридцать "
Case 4
SS = "сорок "
Case 5
SS = "пятьдесят "
Case 6
SS = "шестьдесят "
Case 7
SS = "семьдесят "
Case 8
SS = "восемьдесят "
Case 9
SS = "девяносто "
End Select
S = SS + S
End Select
SS = ""
Select Case Int(N / 100) ' выделить цифру сотен
Case 1
SS = "сто "
Case 2
SS = "двести "
Case 3
SS = "триста "
Case 4
SS = "четыреста "
Case 5
SS = "пятьсот "
Case 6
SS = "шестьсот "
Case 7
SS = "семьсот "
Case 8
SS = "восемьсот "
Case 9
SS = "девятьсот "
End Select
S = SS + S
prop3t = S

End Function

Function propis(num)
' Аргументы: целое положительное число < 1 000 000 000 000
' Назначение: преобразует это число в число прописью (с рублями)
' Возвращает: строку, содержащую число прописью
' например propis(3000119) -> три миллиона сто девятнадцать рублей
' Вызывает: функции prop3(), prop3t() и prop3rub()
' Вызов: propis()
' Составил: 4.07.96г.

N = Int(num + 0.5) ' для правильного округления
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число
S = prop3rub(M) ' преобразовать младшие три цифры и приписать рублей/рубля/рубль
N = Int(num / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число тысяч
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "тысяча "
Case 2 To 4
L = "тысячи "
Case Else
L = "тысяч "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "тысяч "
End Select
S = prop3t(M) + L + S ' вызов prop3t для преобразования тысяч
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллион "
Case 2 To 4
L = "миллиона "
Case Else
L = "миллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллионов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллиардов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллиард "
Case 2 To 4
L = "миллиарда "
Case Else
L = "миллиардов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллиардов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллиардов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число триллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "триллион "
Case 2 To 4
L = "триллиона "
Case Else
L = "триллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "триллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования триллионов
End If
S = UCase(Mid(S, 1, 1)) + Mid(S, 2) ' первую букву сделать заглавной
propis = S
End Function

Function propisd(num)
' Аргументы: целое положительное число < 1 000 000 000 000
' Назначение: преобразует это число в число прописью (без копеек)
' Возвращает: строку, содержащую число прописью
' например propisd(3000119) -> три миллиона сто девятнадцать
' Вызывает: функции prop3() и prop3t()
' Вызов: propisd()
' Составил: 4.07.96г.

N = Int(num + 0.5) ' для правильного округления
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число
S = prop3(M) ' преобразовать младшие три цифры
N = Int(num / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число тысяч
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "тысяча "
Case 2 To 4
L = "тысячи "
Case Else
L = "тысяч "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "тысяч "
End Select
S = prop3t(M) + L + S ' вызов prop3t для преобразования тысяч
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллион "
Case 2 To 4
L = "миллиона "
Case Else
L = "миллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллионов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число миллиардов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "миллиард "
Case 2 To 4
L = "миллиарда "
Case Else
L = "миллиардов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "миллиардов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования миллиардов
End If
N = Int(N / 1000) ' отбросить три последние цифры
M = N - 1000 * Int(N / 1000) ' выделить трехзначное число триллионов
L = ""
If M > 0 Then
Select Case (M - 10 * Int(M / 10))
Case 1
L = "триллион "
Case 2 To 4
L = "триллиона "
Case Else
L = "триллионов "
End Select
Select Case (M - 100 * Int(M / 100)) ' поправка для 11,12,13,14
Case 11 To 14
L = "триллионов "
End Select
S = prop3(M) + L + S ' вызов prop3 для преобразования триллионов
End If
S = UCase(Mid(S, 1, 1)) + Mid(S, 2) ' первую букву сделать заглавной
propisd = S
End Function


Function propkop(N)
' Аргументы: двухзначное целое положительное число
' Назначение: преобразует это число в число с допиской копеек/копейки/копейка
' Возвращает: строку, содержащую число прописью
' например propkop(32) -> 32 копейки
' Вызов: из функции propiskop()
' Составил: 12.01.98г.

S = " копеек"
If N < 10 Or N > 19 Then
i = 10 * Int(N / 10)
Select Case (N - i) ' выделить цифру единицы
Case 1
S = " копейка"
Case 2 To 4
S = " копейки"
End Select
End If
If N > 9 Then
propkop = Str$(N) + S
Else
propkop = "0" + Mid(Str$(N), 2) + S
End If
End Function

Код: vbnet
1.
2.


Модератор: Портянка убрана в спойлер
...
Рейтинг: 0 / 0
24.09.2012, 17:33
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970329
безобъявления
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
безобъявления
Гость
serbar62,

У вас переменные беспризорные, не объявленные
...
Рейтинг: 0 / 0
24.09.2012, 17:47
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970355
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
serbar62Если честно, то алгоритм сильно не копал
Зачем столько букв? Я спросил, чему равна переменная.
...
Рейтинг: 0 / 0
24.09.2012, 18:00
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970516
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Владимир Саныч, коротко, не знаю. Весь алгоритм программы написан доступными средствами ACCESS без использования программирования VBA, но тут получается, без него никуда. Посему и прошу помощи, подробно объясните, где они, эти беспризорные переменные и как это безобразие исправить. Лучше на примере.
...
Рейтинг: 0 / 0
24.09.2012, 20:45
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970527
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
Самой программы (и того, что можно увидеть через форум) недостаточно. Надо запустить программу при помощи Аксесса, причем с теми данными, которые у Вас, дойти до того момента, когда оно выругается, и посмотреть, чему равна переменная. Этот процесс называется отладка, и для нее, как я уже сказал, нужен Аксесс и Ваши данные.
...
Рейтинг: 0 / 0
24.09.2012, 20:58
| Ответить | Цитировать | Написать  
Сумма прописью
    #37970529
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
P.S. У Вас уже есть картинка, где одна строка кода выделена желтым. Вот в этот момент наведите мышку на N. Появится надпись со значением этой переменной.
...
Рейтинг: 0 / 0
24.09.2012, 20:59
| Ответить | Цитировать | Написать  
Сумма прописью
    #37971224
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Пишет N=Null, а propkop=Empty
...
Рейтинг: 0 / 0
25.09.2012, 12:59
| Ответить | Цитировать | Написать  
Сумма прописью
    #37971433
Фотография Владимир Саныч
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Владимир СанычПривилегированный пользователь
Модератор форума
serbar62Пишет N=Null
Что и предполагалось. Значит, у Вас в данных где-то вместо суммы сидит дырка.
...
Рейтинг: 0 / 0
25.09.2012, 14:38
| Ответить | Цитировать | Написать  
Сумма прописью
    #37971878
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Буду копать, непонятно одно, почему работает в случае нажатия клавишы на поле?
...
Рейтинг: 0 / 0
25.09.2012, 18:59
| Ответить | Цитировать | Написать  
Сумма прописью
    #37972254
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
В принципе выкопал, почему N=Null. Поле, куда записывается результат вычислений для перевода в пропись является списком. Туда результат вычислений попадает из запроса, по другому я не могу вставить результат суммирования. Если его преобразовать из списка полем, тогда переводит без проблем. Что можно сделать?
...
Рейтинг: 0 / 0
26.09.2012, 02:11
| Ответить | Цитировать | Написать  
Сумма прописью
    #37972261
alvk.
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
alvk.
Участник
serbar62Что можно сделать?

первый столбец в поле со списком - value, второй - text. Думайте, решайте.
...
Рейтинг: 0 / 0
26.09.2012, 02:43
| Ответить | Цитировать | Написать  
Сумма прописью
    #37972345
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Тут дело в том, что видимо при открытие открытие формы значение списка 0, а сумма появляется только при нажатие на список. По-этому не работает перевод. Интересно, как решается вывод суммы в других базах, когда надо суммировать значение и вывести результат?
...
Рейтинг: 0 / 0
26.09.2012, 08:49
| Ответить | Цитировать | Написать  
Сумма прописью
    #37982304
serbar62
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
serbar62
Участник
Проблема была решена простым способом, без сложного алгоритма программирования :-). В запрос, который формировал сумму и отправлял ее в поле формы была введена дополнительная колонка и вставлена строчка: Выражение1: propiskop([ITOGO]). В результате в запросе в поле ITOGO формировалась сумма числами, а в поле Выражение1 сумма прописью. А ее уже потом вставлял куда надо без проблем.
...
Рейтинг: 0 / 0
03.10.2012, 16:26
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Сумма прописью
    #39476712
Alexey5555
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Alexey5555
Гость
abend, как сменить отображаемую валюту?
...
Рейтинг: 0 / 0
23.06.2017, 12:53
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Сумма прописью
    #39836354
Равшан353
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Равшан353
Гость
Здравствуйте, у меня access 2016, и Ваш файл не открывает, можете помочь?
...
Рейтинг: 0 / 0
11.07.2019, 13:32
| Ответить | Цитировать | Написать  
67 сообщений из 67, показаны все 3 страниц
  все  
Форумы / Microsoft Access [игнор отключен] [закрыт для гостей] / Сумма прописью
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?all=1&fid=45&tid=1610599]:
 0ms
get settings:
 7ms
get forum list:
 13ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 58ms
get topic data:
 12ms
get forum data:
 3ms
get page messages:
 90ms
get tp. blocked users:
 2ms
others: 11ms
total:  202ms
созд. / загр.: 202ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]