Option Compare Database
'''''''''''''''''''''''''''''''''''''
' Функция выводить сумму прописью '
' Вход: Сумма число '
' Выход: Сумма прописью '
'''''''''''''''''''''''''''''''''''''
Function SummaPropis(ByVal tt As Variant) As String
On Error GoTo Err_SummaPropis
Dim count As Integer, i As Integer, n As Integer, l As Integer
Dim kop As String, snum As String, s As String, e As String, t As String
Dim text As String
Static m1(8) As String
Static m2(8) As String
Static m3(8) As String
Static mm(8) As String
Static prob As String
m1(0) = "сто"
m1(1) = "двести"
m1(2) = "триста"
m1(3) = "четыреста"
m1(4) = "пятьсот"
m1(5) = "шестьсот"
m1(6) = "семьсот"
m1(7) = "восемьсот"
m1(8) = "девятьсот"
m2(0) = "десять"
m2(1) = "двадцать"
m2(2) = "тридцать"
m2(3) = "сорок"
m2(4) = "пятьдесят"
m2(5) = "шестьдесят"
m2(6) = "семьдесят"
m2(7) = "восемьдесят"
m2(8) = "девяносто"
m3(0) = "один"
m3(1) = "два"
m3(2) = "три"
m3(3) = "четыре"
m3(4) = "пять"
m3(5) = "шесть"
m3(6) = "семь"
m3(7) = "восемь"
m3(8) = "девять"
mm(0) = "одиннадцать"
mm(1) = "двенадцать"
mm(2) = "тринадцать"
mm(3) = "четырнадцать"
mm(4) = "пятнадцать"
mm(5) = "шестнадцать"
mm(6) = "семнадцать"
mm(7) = "восемнадцать"
mm(8) = "девятнадцать"
prob = " "
t = Format(tt, "000000000000.00")
i = 0
Do
i = i + 1
Loop While Mid$(t, i, 1) = "0"
i = i - 1
e = String$(i, 32)
t = Right$(t, 15 - i)
t = e & t
count = 4
kop = Right$(t, 2)
text = Left$(t, 12)
snum = ""
i = 1
Do While count > 0
s = Mid$(text, i, 1)
If s <> " " And s <> "0" Then
n = Val(s) - 1
snum = snum & m1(n)
snum = snum & prob
End If
i = i + 1
s = Mid$(text, i, 1)
If s <> " " And s <> "0" And s <> "1" Then
n = Val(s) - 1
snum = snum & m2(n) & prob
End If
i = i + 1
s = Mid$(text, i, 1)
If s <> " " And s <> "0" Then
If Mid$(text, i - 1, 1) = "1" Then
n = Val(s) - 1
snum = snum & mm(n) & prob
Else
n = Val(s) - 1
snum = snum & m3(n) & prob
End If
End If
If s = "0" And Mid$(text, i - 1, 1) = "1" Then
snum = snum & m2(0) & prob
End If
If s <> " " Then
Select Case count
Case 4:
Select Case s
Case "1":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиард "
Else
GoTo mi
End If
Case "2":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиарда "
Else
GoTo mi
End If
Case "3":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиарда "
Else
GoTo mi
End If
Case "4":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиарда "
Else
GoTo mi
End If
Case Else
mi: snum = snum & "миллиардов "
End Select
Case 3:
Select Case s
Case "1":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллион "
Else
GoTo ma
End If
Case "2":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиона "
Else
GoTo ma
End If
Case "3":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиона "
Else
GoTo ma
End If
Case "4":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "миллиона "
Else
GoTo ma
End If
Case Else
ma: If Mid$(text, i - 2, 1) = "0" And Mid$(text, i - 1, 1) = "0" And s = "0" Then
Else
snum = snum & "миллионов "
End If
End Select
Case 2:
Select Case s
Case "1":
If Mid$(text, i - 1, 1) <> "1" Then
l = Len(snum) - 3
snum = Left$(snum, l)
snum = snum & "на тысяча "
Else
GoTo ti
End If
Case "2":
If Mid$(text, i - 1, 1) <> "1" Then
l = Len(snum)
snum = Left$(snum, l - 2)
snum = snum & "е тысячи "
Else
GoTo ti
End If
Case "3":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "тысячи "
Else
GoTo ti
End If
Case "4":
If Mid$(text, i - 1, 1) <> "1" Then
snum = snum & "тысячи "
Else
GoTo ti
End If
Case Else
ti: If Mid$(text, i - 2, 1) = "0" And Mid$(text, i - 1, 1) = "0" And s = "0" Then
Else
snum = snum & "тысяч "
End If
End Select
Case 1:
End Select
End If
i = i + 1
count = count - 1
Loop
' If Mid$(text, 11, 1) <> "1" Then
' Select Case Right$(text, 1)
' Case "1":
' snum = snum & "рубль"
' Case "2":
' snum = snum & "рубля"
' Case "3":
' snum = snum & "рубля"
' Case "4":
'' snum = snum & "рубля"
' Case Else
' snum = snum & "рублей"
' End Select
' Else
' snum = snum & "рублей"
' End If
snum = snum & "руб. " & kop & " коп."
s = Left$(snum, 1)
n = Asc(s) - 32
s = Chr$(n)
l = Len(snum) - 1
snum = Right$(snum, l)
SummaPropis = s & snum
Exit_SummaPropis:
Exit Function
Err_SummaPropis:
MsgBox Err.Description, , "Функия - SummaPropis"
Resume Exit_SummaPropis
End Function |
