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

АВТОР: Максименко Юрий
По материалам: 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