Число прописью...

[Ramzes]

Эсть проблемка... Вот прога у меня печатает реестр документов. и их сумму (в цифрах), а как печатать сумму прописью(буквами)?

[codemaster]

Как вариант

Код: Выделить всё

Option Explicit
'=CurrencyInWords ([N])
'=DollarsInWords([N])
'=NumberInWords([N];1;"полированный стол";"полированных стола";"полированных столов")

Function TriadInWords$(Triad$, Gender As Long, Unit1$, Unit2$, Unit5$)
    Dim Result$
    If Triad = "000" Then
        TriadInWords = ""
    Else
        Result = Choose(Mid(Triad, 1, 1) + 1, "", " сто", " двести", " триста", " четыреста", _
            " пятьсот", " шестьсот", " семьсот", " восемьсот", " девятьсот")
        If Mid(Triad, 2, 1) = 1 Then
            Result = Result & " " & Choose(Mid(Triad, 3, 1) + 1, "десять", "одиннадцать", _
                "двенадцать", "тринадцать", "четырнадцать", "пятнадцать", "шестнадцать", _
                "семнадцать", "восемнадцать", "девятнадцать") & " " & Unit5
        Else
            Result = Result & Choose(Mid(Triad, 2, 1) + 1, "", "", " двадцать", " тридцать", _
                " сорок", " пятьдесят", " шестьдесят", " семьдесят", " восемьдесят", " девяносто")
            Select Case Mid(Triad, 3, 1)
                Case 1: Result = Result & Choose(Gender, " один ", " одна ", " одно ") & Unit1
                Case 2: Result = Result & Choose(Gender, " два ", " две ", " два ") & Unit2
                Case 3: Result = Result & " три " & Unit2
                Case 4: Result = Result & " четыре " & Unit2
                Case Else: Result = Result & Choose(Mid(Triad, 3, 1) + 1, "", "", "", "", "", _
                    " пять", " шесть", " семь", " восемь", " девять") & " " & Unit5
            End Select
        End If
        TriadInWords = Result
    End If
End Function

Function NumberInWords(Number, Gender As Long, Unit1$, Unit2$, Unit5$)
    Dim Image$, Modulus$
    If IsNull(Number) Then
        NumberInWords = Null
    Else
        Image = Format(Abs(Number), String(15, "0"))
        If Image = 0 Then
            NumberInWords = Trim("ноль " & Unit5)
        Else
            If Len(Image) > 15 Then
                Modulus = " <много> " & Unit5
            Else
                Modulus = TriadInWords(Mid(Image, 1, 3), 1, "триллион", "триллионa", "триллионов") & _
                    TriadInWords(Mid(Image, 4, 3), 1, "миллиард", "миллиарда", "миллиардов") & _
                    TriadInWords(Mid(Image, 7, 3), 1, "миллион", "миллиона", "миллионов") & _
                    TriadInWords(Mid(Image, 10, 3), 2, "тысяча", "тысячи", "тысяч") & _
                    IIf(Mid(Image, 13, 3) = "000", " " & Unit5, _
                        TriadInWords(Mid(Image, 13, 3), Gender, Unit1, Unit2, Unit5))
            End If
            NumberInWords = Trim(IIf(Number < 0, "минус", "") & Modulus)
        End If
    End If
End Function

Public Function AmountInWords(Amount, Gender1 As Long, Dollar1$, Dollar2$, Dollar5$, Gender2 As Long, Cent1$, Cent2$, Cent5$)
    Dim Image$
    If IsNull(Amount) Then
        AmountInWords = Null
    Else
        Image = Format(Amount, "0.00")
        AmountInWords = IIf(Left(Image, 1) = "-", "минус ", "") & _
            NumberInWords(Abs(Left(Image, Len(Image) - 3)), Gender1, Dollar1, Dollar2, Dollar5) & _
            ", " & NumberInWords(Right(Image, 2), Gender2, Cent1, Cent2, Cent5)
    End If
End Function

Function IntegerInWords(Number)
    IntegerInWords = NumberInWords(Number, 1, "", "", "")
End Function

Function RoublesInWords(Amount)
    RoublesInWords = AmountInWords(Amount, 1, "рубль", "рубля", "рублей", 2, "копейка", "копейки", "копеек")
End Function

Function DollarsInWords(Amount)
    DollarsInWords = AmountInWords(Amount, 1, "доллар", "доллара", "долларов", 1, "цент", "цента", "центов")
End Function

Function MarksInWords(Amount)
    MarksInWords = AmountInWords(Amount, 1, "марка", "марки", "марок", 2, "пфеннинг", "пфеннинга", "пфеннингов")
End Function




[GSerg]

http://bbs.vbstreets.ru/viewtopic.php?p=21450#21450

[Ramzes]

Благодарю! Вот сейчас читаю

[pitbull]

Вот еще:

Код: Выделить всё

-------------------------------------------------------
'Функция IntTxt печатает в поле прописью сумму,
'набранную цифрами в другом поле без названия
'денежных единиц.
'Используется совместно с функцией LetterSum.
'-------------------------------------------------------
Function IntTxt(Number As Long) As String
Dim Z As String, tmp As String
Dim I As Integer, P As Integer, N As Integer, V As Integer
If Number = 0 Then
  IntTxt = "ноль"
  Exit Function
End If
Z = Trim$(Str$(Number))
N = Fix((Len(Z) - 1) / 3)
ReDim D(0 To N) As Integer
For I = Len(Z) To 1 Step -1
  P = Fix((Len(Z) - I) / 3)
  tmp = Mid$(Z, I, 1) + tmp
  D(P) = Val(tmp)
  If Len(tmp) = 3 Then tmp = ""
Next I
Z = ""
For I = N To 0 Step -1
  V = D(I)
  P = Int(V / 100)
  Select Case P
    Case 0
    Case 1
      Z = Z + "сто "
    Case 2
      Z = Z + "двести "
    Case 3
      Z = Z + "триста "
    Case 4
      Z = Z + "четыреста "
    Case 5
      Z = Z + "пятьсот "
    Case 6
      Z = Z + "шестьсот "
    Case 7
      Z = Z + "семьсот "
    Case 8
      Z = Z + "восемьсот "
    Case 9
      Z = Z + "девятьсот "
  End Select
  P = V - 100 * Int(V / 100)
  Select Case Int(P / 10)
    Case 0
    Case 1
      Select Case P - 10 * Int(P / 10)
        Case 0
          Z = Z + "десять "
        Case 1
          Z = Z + "оди"
        Case 2
          Z = Z + "две"
        Case 3
          Z = Z + "три"
        Case 4
          Z = Z + "четыр"
        Case 5
          Z = Z + "пят"
        Case 6
          Z = Z + "шест"
        Case 7
          Z = Z + "сем"
        Case 8
          Z = Z + "восем"
        Case 9
          Z = Z + "девят"
      End Select
      If (P - 10 * Int(P / 10)) <> 0 Then Z = Z + "надцать "
    Case 2
      Z = Z + "двадцать "
    Case 3
      Z = Z + "тридцать "
    Case 4
      Z = Z + "сорок "
    Case 5
      Z = Z + "пятьдесят "
    Case 6
      Z = Z + "шестьдесят "
    Case 7
      Z = Z + "семьдесят "
    Case 8
      Z = Z + "восемьдесят "
    Case 9
      Z = Z + "девяносто "
  End Select
  If (Int(P / 10)) <> 1 Then
    Select Case P - 10 * Int(P / 10)
      Case 0
      Case 1
        Select Case I
          Case 1
            Z = Z + "одна "
          Case Else
            Z = Z + "один "
        End Select
      Case 2
        Select Case I
          Case 1
            Z = Z + "две "
          Case Else
            Z = Z + "два "
        End Select
      Case 3
        Z = Z + "три "
      Case 4
        Z = Z + "четыре "
      Case 5
        Z = Z + "пять "
      Case 6
        Z = Z + "шесть "
      Case 7
        Z = Z + "семь "
      Case 8
        Z = Z + "восемь "
      Case 9
        Z = Z + "девять "
    End Select
  End If
  Select Case I
    Case 0
      tmp = ""
    Case 1
      tmp = DTxt(V, "тысяча", "тысячи", "тысяч")
    Case 2
      tmp = DTxt(V, "миллион", "миллиона", "миллионов")
    Case 3
      tmp = DTxt(V, "миллиард", "миллиарда", "миллиардов")
    Case Else
      tmp = "#"
  End Select
  If I > 0 Then Z = Z + tmp + " "
Next I
IntTxt = Z
End Function


Теперь для ед. Измерения

Код: Выделить всё

Function LetterSum(sum As Currency) As String
Dim R As Long, K As Integer, tmp As Integer
Dim Z As String, ZR As String, ZK As String
Const RKdiv = "  "
R = Int(sum)
K = (sum - R) * 100
ZR = IntTxt(R) + " " + DTxt(R, "рубль", "рубля", "рублей")
ZK = Format$(K, "00") + " " + DTxt(K, "копейка", "копейки", "копеек")
Z = ZR & RKdiv & ZK
Z = UCase$(Mid$(Z, 1, 1)) + Mid$(Z, 2)
LetterSum = Z
End Function
------------------------------------------------------------------------------------
Function DTxt(Number As Variant, W0 As String, W1 As String, W2 As String) As String
Dim tmp As String, Z As Integer
tmp = Trim$(Str$(Number))
Z = Val(Right$(tmp, 2))
If Z < 20 Then
    Select Case Z
      Case 0, 5 To 19
        tmp = W2
      Case 1
        tmp = W0
      Case 2, 3, 4
        tmp = W1
    End Select
  Else
    Select Case (Z - 10 * Int(Z / 10))
      Case 0, 5 To 9
        tmp = W2
      Case 1
        tmp = W0
      Case 2, 3, 4
        tmp = W1
    End Select
End If
DTxt = tmp
End Function