Число словами

[flyinsky]

Здравствуйте всем. Вобщем проблемка такая. Нужно создать функцию которая переводила бы число в слова, типа 22 - двадцать два. Искал решений море, но мне не нужно лишних понтов, хватит подсчета и до 100 . Начал делать вот так но дальше дело не продвинулось

Function chisla(x) As String
Select Case x
 Case 1
 chisla = "один"
  Case 2
 chisla = "два"
  Case 3
 chisla = "три"
  Case 4
 chisla = "четыре"
   Case 5
 chisla = "пять"
  Case 6
 chisla = "шесть"
  Case 7
 chisla = "семь"
  Case 8
 chisla = "восемь"
  Case 9
 chisla = "девять"
  Case 10
 chisla = "десять"
 End Select
End Function
Function chisla1(y) As String
 Select Case y
 Case 11
 chisla = "одиннадцать"
 Case 12
 chisla = "двенадцать"
 End Select
End Function

И еще как обьеденить функции в одну чтоб при выборе функции я пользовался только одной функцией а не разными.

[Teslenko_EA]

Здравствуйте flyinsky.
Вы без "лишних понтов" решили изобретать велосипед? Знакомиться с VB(A) лучше не на конструкциях самостоятельного производства, а на готовых образцах, например таком.
Евгений.

[flyinsky]

спасибо за ответ

[Sasha_Smirnov]

Поскольку вопрос о получении имён числительных (из их цифровых значений) задан вообще, а не только для Excel, то, возможно, будет полезным и этот* пост.

Только там в коде надо заменить

"\*Roman"

на

"\*CardText"

Интересно, что

"\*OrdText"

даёт слова «первый», «второй», ..., «сотый» и т. д. на языке, установленном в точке ввода, и с заглавной буквы, если ключ (Roman, CardText или OrdText) введён с заглавной.

Но всё это в документах Word, каковой и прилагаю.
Открываете — включаете VBA — выделяете число — жмёте альт-F8 — двойной щелчок по имени программы. Число преобразуется.

____________________________
* Надеюсь, его автор простит мне столь вольное обращение с его идеей!

[IgorGO]

так чтобы без понтов, у меня получилось следующее:

Function odst(d As Integer, p As Integer, t As Integer) As String
 Dim s As String
 s = ""
 Select Case d
 Case 1
  Select Case p
  Case 2 To 5
   s = " один"
  Case 1
   s = " одна"
  Case Else
   If (t And 4) = 4 Then s = " один" Else s = " одна"
  End Select
 Case 2
  Select Case p
  Case 2 To 5
   s = " два"
  Case 1
   s = " дві"
  Case Else
   If (t And 4) = 4 Then s = " два" Else s = " дві"
  End Select
 Case 3
  s = " три"
 Case 4
  s = " чотири"
 Case 5
  s = " п'ять"
 Case 6
  s = " шість"
 Case 7
  s = " сім"
 Case 8
  s = " вісім"
 Case 9
  s = " дев'ять"
 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 = " дев'ятнадцять"
 End Select
 If p = -1 Then
  If t = 0 Then odst = s & " коп.": Exit Function
  If (t And 3) > 0 Then
   Select Case d
   Case 1
    odst = s & " копійка"
   Case 2, 3, 4
    odst = s & " копійки"
   Case Else
    odst = s & " копійок"
   End Select
  End If
 End If
 If p = 0 Then
  If t = 0 Then odst = s & " грн.": Exit Function
  If (t And 3) = 0 Then odst = s: Exit Function
  If (t And 3) > 0 Then
   Select Case d
   Case 1
    odst = s & " гривня"
   Case 2, 3, 4
    odst = s & " гривні"
   Case Else
    odst = s & " гривень"
   End Select
  End If
 End If
 If p = 1 Then
  Select Case d
  Case 1
   odst = s & " тисяча"
  Case 2, 3, 4
   odst = s & " тисячі"
  Case Else
   odst = s & " тисяч"
  End Select
 End If
 If p = 2 Then
  Select Case d
  Case 1
   odst = s & " мільйон"
  Case 2, 3, 4
   odst = s & " мільйони"
  Case Else
   odst = s & " мільйонів"
  End Select
 End If
 If p = 3 Then
  Select Case d
  Case 1
   odst = s & " мільярд"
  Case 2, 3, 4
   odst = s & " мільярди"
  Case Else
   odst = s & " мільярдів"
  End Select
 End If
End Function

Function desst(d As Integer) As String
 desst = ""
 Select Case d
 Case 2
  desst = " двадцять"
 Case 3
  desst = " тридцять"
 Case 4
  desst = " сорок"
 Case 5
  desst = " п'ятдесят"
 Case 6
  desst = " шістдесят"
 Case 7
  desst = " сімдесят"
 Case 8
  desst = " вісімдесят"
 Case 9
  desst = " дев'яносто"
 End Select
End Function

Function sotst(d As Integer) As String
 sotst = ""
 Select Case d
 Case 1
  sotst = " сто"
 Case 2
  sotst = " двісті"
 Case 3
  sotst = " триста"
 Case 4
  sotst = " чотириста"
 Case 5
  sotst = " п'ятсот"
 Case 6
  sotst = " шістсот"
 Case 7
  sotst = " сімсот"
 Case 8
  sotst = " вісімсот"
 Case 9
  sotst = " дев'ятсот"
 End Select
End Function


Function LastWord(s As String) As String
Dim p As Integer
 p = Len(s)
 If p = 0 Then LastWord = "": Exit Function
 While Mid(s, p, 1) <> " "
  p = p - 1
 Wend
 LastWord = Right(s, Len(s) - p + 1)
End Function


Function Por(d As Double) As Integer
' Определяет порядок числа (до 0 -> -1; до 1000 -> 0, до 1000000 -> 2...)
Dim i As Integer
 i = 6
 Do
  i = i - 1
 Loop Until (d >= 10 ^ (3 * i)) Or (i = -1)
 Por = i
End Function


Public Function Prop(ByVal d As Double, Optional t As Integer = 0) As String
't = 0 - грн. 00 коп.
'    1 - гривен 00 копеек
'    2 - гривен ноль копеек
'    4 - муж.род.
'    8 - целая часть
 d = Round(d, 2)
 Prop = Props("", Por(d), d, t)
End Function


Private Function Props(St As String, i As Integer, d As Double, t As Integer) As String
Dim sot As Integer, des As Integer, od As Integer, s As String, k As Integer, ost As Single, wout As Integer
 k = i
 If (d < 1) And (St = "") Then St = "нуль грн."
 If i < 0 Then k = 0: d = Round(d * 100): s = Format(d, " 00")
 ost = d - Int(d): d = Int(d)
 sot = d \ 10 ^ (3 * k + 2)
 d = d - sot * 10 ^ (3 * k + 2)
 des = d \ 10 ^ (3 * k + 1)
 If des > 1 Then d = d - des * 10 ^ (3 * k + 1)
 If i = -1 Then od = Round(d) \ 10 ^ (3 * k) Else od = d \ 10 ^ (3 * k)
 If (i = -1) And (des = 0) And (od = 0) And ((t And 2) = 2) Then St = St & " нуль"
 d = d - od * 10 ^ (3 * k)
 St = St & sotst(sot)
 wout = Len(St)
 St = St & desst(des)
 St = St & odst(od, i, t)
 If i < 0 Then
  If (t And 2) = 0 Then
   St = Left(St, wout) & s & LastWord(St)
  End If
  St = LTrim(St)
  St = UCase(Left(St, 1)) & Mid(St, 2)
  If t >= 4 Then St = Left(St, wout)
  Props = St: Exit Function
 End If
 Props = Props(St, i - 1, d + ost, t)
End Function

Используйте функцию Prop. Первый параметр собственно число, которое необходимо прописать, второй параметр равен
' 0 - грн. 00 коп.
' 1 - гривен 00 копеек
' 2 - гривен ноль копеек
' 4 - муж.род.
' 8 - целая часть
Я использовал это для заполнения платежных поручений и доверенностей.
можно прописать Тридцать одна коробка, или Тридцать один ящик.

[Stilet]

Фух... Что за мания код раздувать до нельзя?
Вот смотри:

function aga(s:string):string;
 const adyn:array[1..10] of string=('Один','два','три','четыре','пять','шесть','семь','восемь','девять','десять');
 const desat:array[2..9] of string=('двадцать','тридцать','сорок','пятьдесят','шестьдесят','семьдесят','восемдесят','девяносто');
var i:integer;
begin
 if length(s)=1 then Result:=adyn[StrToInt(s)] else begin
  if s[1]='1' then Result:=adyn[StrToInt(s[2])]+'надцать' else
   Result:=desat[StrToInt(s[1])]+' '+adyn[StrToInt(s[2])];
 end;
end;

А вот так ею пользоваться:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin

 if (key=#13)and(length(Edit1.Text)<3) then Caption:=aga(Edit1.Text);

end;

Тут до 99 учитывается

[IgorGO]

уважаемый Stilet,
1) а ничего что бейсик не понимает синтаксис паскаля?

2) насколько я осведомлен, по-русски пишется:
одиннадцать двенадцать тринадцать четырнадцать пятнадцать шестнадцать семнадцать восемнадцать девятнадцать
а не дванадцать, четыренадцать, пятьнадцать и т.д.

3) если Вы будете считать ящики, то "один" и "два" - это то, что надо, а если бутылки? - их будет "одна" и "две" соответственно.
Надо бы код раздуть немного, чтобы правильно называть числа словами.

[Stilet]

а ничего что бейсик не понимает синтаксис паскаля?

Это я конечно попутал, звиняйте. Но смысл в том чтоб вместо CASE использовать массив.

насколько я осведомлен, по-русски пишется:

Я и не говорил что все безупречно - однозначно программу нужно корректировать.

Надо бы код раздуть немного, чтобы правильно называть числа словами.

Ессно. Смысл один - изначально выбирается из массива после чего некий код корректирующий массивный текст.

P.S. надеюсь никто тут не скажет что на бейсике невозможно работать с массивами?

[Sasha_Smirnov]

Возможно. Умеючи-то.

[Hugo121]

Я чтоб не нагружать код работой с родами (и заодно с другими мелочами - скобки, деньги/вещи, нули и т.д.) просто сделал пяток-десяток разных вариантов, и выбираю нужный.
Ну а с Вордом такой вариант (только целые штуки):

Function num2text_word(x As Long, Optional Lang As Long = 1049) As String
'Для турецкого второй аргумент 1055, для английского 1033 и т.д.
'Русский 1049, латышский 1062
'Если подключить Reference на Microsoft Word Object Library, можно использовать константы ворда wdTurkish, wdEnglishUS и т.д.

    With CreateObject("word.document")
        .Range.LanguageID = Lang
        .Fields.Add .Range, Type:=-1, Text:="=" & x & " \* cardtext"
        num2text_word = Replace(.Range.Text, vbCr, "")
        .Close 0
    End With
End Function