Сумма Прописью на Английском языке (Максименко Юрий)

АВТОР: Максименко Юрий
По материалам: http://db-maker.narod.ru

'СУММА ПРОПИСЬЮ НА АНГЛИЙСКОМ ЯЗЫКЕ
'===========================================================================
'АВТОР: Максименко Юрий http://db-maker.narod.ru

'Описание
'----------
'Главной функцией модуля является sumEnglish_Long(), возвращающая пропись
'от длинного целого числа (в конце модуля приводится пример, как применять её
'и для чисел с дробной частью)

'Разрабатывалась на основе правил:
'http://accent.hotmail.ru/languages/english/numeral.html

Public Function sumEnglish_Long(ByVal s As Long, Optional ifZero As String = "") As String
'ВХОДНЫЕ ПАРАМЕТРЫ
's - сумма
'ifZero - строка, возвращаемая при s=0

Dim i, stepen, rank As Integer
Dim group As Long
Dim tempS, tempS1 As Long
Dim rankName As String

Dim rankNames(4) As String
Dim rankNumbers(4) As Integer
Dim tmp_s As Long

If s = 0 Then
    sumEnglish_Long = ifZero
    Exit Function
End If

rankNames(0) = ""
rankNames(1) = "thousand"
rankNames(2) = "million"
rankNames(3) = "billion"

'Определим порядок числа
tmp_s = s
stepen = 0
Do While tmp_s > 0
    tmp_s = Int(tmp_s / 10)
    If (tmp_s > 0) Then stepen = stepen + 1
Loop
    
    
    
'Определим количество групп разрядов по три
rank = Int(stepen / 3)
tempS = Abs(s)
sumEnglish_Long = ""
For i = rank To 0 Step -1
    group = Int(tempS / (10 ^ (3 * i)))
    tempS = tempS - group * (10 ^ (3 * (i)))
    
'Debug.Print "i=" & i & ", tempS=" & tempS & ", group=" & group
    If group = 0 Then
        rankName = ""
    Else
        rankName = rankNames(i)
    
    End If
    
    sumEnglish_Long = sumEnglish_Long & " " & sumEnglish_3(group) & " " & rankName

Next i

If s < 0 Then sumEnglish_Long = "minus " & sumEnglish_Long
sumEnglish_Long = strReplace(sumEnglish_Long, "  ", " ")
sumEnglish_Long = strReplace(sumEnglish_Long, "  ", " ")

sumEnglish_Long = Trim(sumEnglish_Long)
End Function
'Возвращает пропись трёхзначного целого числа
Function sumEnglish_3(ByVal s As Long, Optional ifZero As String = "") As String
    Dim n As Long
    Dim dec As String
    Dim hundred As String
    
    sumEnglish_3 = ifZero
    n = Int(s / 100)
    
    hundred = sumEnglish_hundreds(s)
    dec = sumEnglish_2(s - 100 * n, "")
    sumEnglish_3 = hundred
    If (dec <> "") And (hundred <> "") Then sumEnglish_3 = sumEnglish_3 & " and"
    sumEnglish_3 = sumEnglish_3 & " " & dec
    
End Function

Function sumEnglish_hundreds(s As Long) As String
    Dim n As Long
    
    sumEnglish_hundreds = ""
    n = Int(s / 100)
    If n > 0 Then
        sumEnglish_hundreds = sumEnglish_1(n) & " hundred"
    Else
        
    End If
    
End Function
'Возвращает пропись двухзначного целого числа
Function sumEnglish_2(s As Long, Optional ifZero As String = "") As String
    Dim n As Long
    Dim dec, one As String
    If s < 10 Then
        sumEnglish_2 = sumEnglish_1(s, ifZero)
    Else
        If s < 20 Then
    
            Select Case s
                Case 10
                    sumEnglish_2 = "ten"
                Case 11
                    sumEnglish_2 = "eleven"
                Case 12
                    sumEnglish_2 = "twelve"
                Case 13
                    sumEnglish_2 = "thirteen"
                Case 14
                    sumEnglish_2 = "fourteen"
                Case 15
                    sumEnglish_2 = "fifteen"
                    
                Case Else
                    sumEnglish_2 = sumEnglish_1(s - 10) & "teen"
            End Select
        
        Else
            n = Int(s / 10)
            Select Case n
                Case 2
                    dec = "twenty"
                Case 3
                    dec = "thirty"
                Case 4
                    dec = "forty"
                Case 5
                    dec = "fifty"
                Case 6
                    dec = "sixty"
                Case 7
                    dec = "seventy"
                Case 8
                    dec = "eighty"
                Case 9
                    dec = "ninety"
               
            End Select
            
            one = sumEnglish_1(s - 10 * n)
            sumEnglish_2 = dec
            If (one <> "") And (dec <> "") Then sumEnglish_2 = sumEnglish_2 & "-"
            sumEnglish_2 = sumEnglish_2 & one
            
        End If
    
    End If

End Function
'Возвращает пропись цифры
Function sumEnglish_1(s As Long, Optional ByVal ifZero As String = "") As String
Select Case s

    Case 0
        sumEnglish_1 = ifZero
    Case 1
        sumEnglish_1 = "one"
    Case 2
        sumEnglish_1 = "two"
    Case 3
        sumEnglish_1 = "three"
    Case 4
        sumEnglish_1 = "four"
    Case 5
        sumEnglish_1 = "five"
    Case 6
        sumEnglish_1 = "six"
    Case 7
        sumEnglish_1 = "seven"
    Case 8
        sumEnglish_1 = "eight"
    Case 9
        sumEnglish_1 = "nine"
        
        
End Select

End Function

'=====================================
'О применении функции sumEnglish_Long

'Я не увидел необходимости писать универсальную функцию для чисел с плавающей точкой
'Причина: дробная часть слишком по-разному прописывается в зависимости от применения

'Приведу пример функции, возвращающей сумму прописью для счёта
'(целая часть прописью, "копейки" цифрами)


Function forInvoiceEn(ByVal s As Single, Optional currName As String = "RUR")

Dim i, d As Long
Dim iCurr, dCurr, dd As String

    i = Int(s) 'Выделяем целую часть ("рубли")
    d = Round((s - i) * 100, 0) 'Выделяем "копейки", преобразуя их в целое число и округляя
    
    dd = Trim(str(d)) 'преобразуем "копейки" в строку
    If Len(dd) = 1 Then dd = "0" & dd  ' добавляем 0 к одноразрядной сумме "копеек"
    
    Select Case currName
        Case "RUR"
            iCurr = " rubles "
            dCurr = " kop."
        Case "USD"
            iCurr = " US dollars "
            dCurr = " cents"
        Case "EURO", "EUR"
            iCurr = " EUR "
            dCurr = " eurocents"
            
    End Select
    forInvoiceEn = sumEnglish_Long(i) & iCurr & dd & dCurr

End Function

'Дублирует  Replace(): эта функция работает как-то странно и в запросах бастует
'Возвращает строку, в которой в исходной строке strSubject подстрока forSearsh заменена на подстроку forReplace
Function strReplace(ByVal strSubject As String, ByVal forSearsh As String, ByVal forReplace As String) As String
    Dim p, l As Integer
    p = InStr(strSubject, forSearsh)
    l = Len(forSearsh)
    Do Until p = 0
        strSubject = Left(strSubject, p - 1) & forReplace & Mid(strSubject, p + l)
        p = InStr(strSubject, forSearsh)
    Loop
    strReplace = strSubject

End Function