Премини към съдържанието
cecov

Преобразуване от "цифром" в "словом"

Препоръчан отговор


Колега от форума ме помоли за код, преобразуващ числова стойност на валута в текст.

Тъй като може да бъде от полза и за някой друг, реших да го публикувам тук.

Кода е на VBA и в момента се използва в MS Access, но може да се използва и в другите приложения на MS Office.

За да преобразувате число в текст, на функцията Num2TXT се подава, като параметър числото, а тя връща текста. Например, ако имате две текстови полета върху формата и искате в полето Text2 да получите текстовото представяне на числото, въведено в полето Text0 (формат Currency) то трябва да напишете :

Text2.Value = Num2Txt(Text0.Value)

в кода за събитие на даден бутон, или в ControlSource на второто поле да зададете

= Num2Txt(Text0.Value)

За десетичен разделител се използва запетая (,), но ако желаете можете да го промените.

Option Compare Database
Option Explicit
Dim warray(9) As String
Dim edin, edna, dwa, dwe, sto, dwesta, trista, stotin, deset, mil, mila, hil, hili, lw, st, i, jn, na
Dim C1

Sub Init()
	warray(1) = "ед"
	warray(2) = "дв"
	warray(3) = "три"
	warray(4) = "четири"
	warray(5) = "пет"
	warray(6) = "шест"
	warray(7) = "седем"
	warray(8) = "осем"
	warray(9) = "девет"

	jn = "ин"
	na = "на"
	sto = "сто"
	dwesta = "двеста"
	trista = "триста"
	stotin = "стотин"
	deset = "десет"
	mil = "милион"
	mila = " милиона"
	hil = "хиляда"
	hili = " хиляди"
	lw = " лв"
	st = " ст"
	i = " и "
End Sub

Function Conv(sstr As String) As String
Dim rstr, astrc, bstrc, cstrc
Dim apos, bpos, cpos

   If Len(sstr) = 3 Then
	 apos = Asc(Mid(sstr, 3, 1)) - Asc("0")
	 bpos = Asc(Mid(sstr, 2, 1)) - Asc("0")
	 cpos = Asc(Mid(sstr, 1, 1)) - Asc("0")
   Else
	 apos = Asc(Mid(sstr, 2, 1)) - Asc("0")
	 bpos = Asc(Mid(sstr, 1, 1)) - Asc("0")
	 cpos = 0
   End If

   If apos = 1 Then
	 If Len(sstr) = 3 Then
		 If C1 = 1 Then
		   astrc = warray(1) + na
		 Else
		   astrc = warray(1) + jn
		 End If
	 Else
	   astrc = warray(1) + na
	 End If
   Else
	 If apos = 2 Then
	   If Len(sstr) = 3 Then
		 If (C1 = 1) And (bpos <> 1) Then
		   astrc = warray(2) + "е"
		 Else
		   astrc = warray(2) + "а"
		 End If
	   Else
		 astrc = warray(2) + "e"
	   End If
	 Else
	   If (apos >= 3) And (apos <= 9) Then astrc = warray(apos)
	 End If
   End If
   
   If bpos = 1 Then
	  If apos = 1 Then
		 bstrc = astrc + "а" + deset
		 astrc = ""
	  Else
		 If apos = 0 Then
			bstrc = deset
			astrc = ""
		 Else
			If (apos >= 2) And (apos <= 9) Then bstrc = astrc + na + deset
			astrc = ""
		 End If
	  End If
   Else
	  If bpos = 2 Then
		bstrc = warray(bpos) + "а" + deset
	  Else
		If (bpos >= 3) And (bpos <= 9) Then bstrc = warray(bpos) + deset
	  End If
   End If
	
  Select Case cpos
	  Case 1
		cstrc = sto
	  Case 2
		cstrc = dwesta
	  Case 3
		cstrc = trista
   Case Else
	  If (cpos >= 4) And (cpos <= 9) Then cstrc = warray(cpos) + stotin
   End Select
 
   rstr = astrc
   If Len(cstrc) > 0 Then
	  If Len(astrc) > 0 Then
		 If Len(bstrc) > 0 Then
			rstr = cstrc + " " + bstrc + i + rstr
		 Else
			rstr = cstrc + i + rstr
		 End If
	  Else
		 If Len(bstrc) > 0 Then
			rstr = cstrc + i + bstrc
		 Else
			rstr = cstrc
		 End If
	  End If
   Else
	  If Len(bstrc) > 0 Then
		 If Len(astrc) > 0 Then
			rstr = bstrc + i + rstr
		 Else
			rstr = bstrc
		 End If
	  End If
   End If

   Conv = rstr
   
End Function

Function Num2Txt(instring As String) As String
Dim LastDelimiter As String, wstr As String, fstr As String, ostring As String, cstrc As String, tstr As String

Init

wstr = instring
LastDelimiter = InStr(1, wstr, ",")

If LastDelimiter > 0 Then
  fstr = Mid(wstr, LastDelimiter + 1, 2)
  wstr = Mid(wstr, 1, LastDelimiter - 1)
End If

If Len(fstr) < 2 Then
  fstr = fstr + Mid("00", 1, 2 - Len(fstr))
End If

ostring = ""
C1 = 0
Do While wstr <> ""

  If Len(wstr) < 3 Then
	wstr = Mid("000", 1, 3 - Len(wstr)) + wstr
  End If
  tstr = Mid(wstr, Len(wstr) - 2, 3)
  cstrc = Conv(tstr)

  Select Case C1
  Case 1
	 If (tstr = "001") Then
	   cstrc = hil
	 ElseIf cstrc <> "" Then
		cstrc = cstrc + hili
	 End If
  Case 2
	 If (tstr = "001") Then
	   cstrc = warray(1) + jn + " " + mil
	 ElseIf cstrc <> "" Then
	   cstrc = cstrc + mila
	 End If
  End Select
  
  If Len(wstr) >= 3 Then
	wstr = Mid(wstr, 1, Len(wstr) - 3)
  Else
	wstr = ""
  End If
  
  If cstrc <> "" Then
	  If (C1 = 0) Then
		If (wstr <> "") And (InStr(1, cstrc, i) = 0) Then
		  ostring = i + cstrc
		Else
		  ostring = cstrc
		End If
	  Else
		ostring = cstrc + " " + ostring
	  End If
  End If

  C1 = C1 + 1
  
Loop

  If Len(fstr) > 0 Then
'	cstrc = Conv(fstr)
	If ostring <> "" Then
	  Num2Txt = ostring + lw + "," + fstr + st
	Else
	  Num2Txt = fstr + st
	End If
  Else
	Num2Txt = ostring + lw
  End If

End Function

Коригирани са някои грешки.

Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Супер.Пробвах работи отлично. А дали може да се намери и преобразуване на английски / немскитекст

Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Ако имаш време сложи коментари, че ми стана интересен кода ама така не го разбирам Публикувано изображение

Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Чудя се може ли този код да се използва в MS Office Word и ако да как?

Всъщност имам нужда от нещо като Popup spell number for Word, само че да преобразува числата на български.

Ако някой се наеме да обясни работата с този код, моля ви много подробно, защото не съм запознат с VBА.

Благодаря!

Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Виждам, че темата не конкретизира програмния език, а има интерес към подобни скриптове, ще поставя и скрипт за PHP.

Скрипта го писах преди няколко месеца, когато бях още да не кажа съвсем нов, така че ако някой има идеи за оптимизирането му да действа както намери за добре.


function read_numbers($number) {
$number=str_replace(',','.',"$number");
$number=@money_format('%.2n',$number);
$number=explode('.',$number);
if (!empty($number[1])) $decimals=$number[1]; else $decimals=0;
$number=$number[0];
$char_count=strlen($number);
for ($i=1;$i<=$char_count;$i++) {
if ($i<=3) {
$pos[1]=substr($number,-$i,1).$pos[1];
}
if ($i<=6 AND $i>3) {
$pos[2]=substr($number,-$i,1).$pos[2];
}
if ($i<=9 AND $i>6) {
$pos[3]=substr($number,-$i,1).$pos[3];
}
}
for ($k=1;$k<=3;$k++) {
for ($i=1;$i<=strlen($pos[$k]);$i++) {
$cur=substr($pos[$k],-$i,1);
unset($temp);
if ($i==3) {
switch($cur) {
case 1: $temp='сто'; break;
case 2: $temp='двеста'; break;
case 3: $temp='триста'; break;
case 4: $temp='четиристотин'; break;
case 5: $temp='петстотин'; break;
case 6: $temp='шестстотин'; break;
case 7: $temp='седемстотин'; break;
case 8: $temp='осемстотин'; break;
case 9: $temp='деветстотин'; break;
}
$pos_hunds[$k]=$temp;
}
if ($i==2) {
switch($cur) {
case 2: $temp='двадесет'; break;
case 3: $temp='тридесет'; break;
case 4: $temp='четиридесет'; break;
case 5: $temp='петдесет'; break;
case 6: $temp='шестдесет'; break;
case 7: $temp='седемдесет'; break;
case 8: $temp='осемдесет'; break;
case 9: $temp='деветдесет'; break;
}
$pos_decs[$k]=$temp;
}
if ($i==1) {
switch($cur) {
case 1: $temp='ед'; break;
case 2: $temp='дв'; break;
case 3: $temp='три'; break;
case 4: $temp='четири'; break;
case 5: $temp='пет'; break;
case 6: $temp='шест'; break;
case 7: $temp='седем'; break;
case 8: $temp='осем'; break;
case 9: $temp='девет'; break;
}
if($pos[$k]>9 AND substr($pos[$k],-2,1)==1) {
if($temp=='ед') $temp=$temp."и";
if($temp=='дв') $temp=$temp."а";
if(substr($pos[$k],-2,1)==1 AND substr($pos[$k],-1,1)==0) $temp='десет';
else $temp=$temp."надесет";
}
if(substr($pos[$k],-2,1)!==1 AND $k!==2) {
if($temp=='ед') $temp=$temp."ин";
if($temp=='дв') $temp=$temp."а";
}
if($k==2) {
if($temp=='ед') $temp=$temp."на";
if($temp=='дв') $temp=$temp."е";
if($pos[$k]==1) $temp='хиляда';
}
$pos_sings[$k]=$temp;
}
}
}
unset($read);
for ($i=1;$i<=3;$i++) {
if (!empty($pos_hunds[$i]) AND !empty($pos_decs[$i]) AND !empty($pos_sings[$i])) $read[$i]=$pos_hunds[$i]." ".$pos_decs[$i]." и ".$pos_sings[$i];
if (!empty($pos_hunds[$i]) AND !empty($pos_decs[$i]) AND empty($pos_sings[$i])) $read[$i]=$pos_hunds[$i]." и ".$pos_decs[$i];
if (!empty($pos_hunds[$i]) AND empty($pos_decs[$i]) AND empty($pos_sings[$i])) $read[$i]=$pos_hunds[$i];
if (!empty($pos_hunds[$i]) AND empty($pos_decs[$i]) AND !empty($pos_sings[$i])) $read[$i]=$pos_hunds[$i]." и ".$pos_sings[$i];;
if (empty($pos_hunds[$i]) AND !empty($pos_decs[$i]) AND !empty($pos_sings[$i])) $read[$i]=$pos_decs[$i]." и ".$pos_sings[$i];
if (empty($pos_hunds[$i]) AND !empty($pos_decs[$i]) AND empty($pos_sings[$i])) $read[$i]=$pos_decs[$i];
if (empty($pos_hunds[$i]) AND empty($pos_decs[$i]) AND !empty($pos_sings[$i])) $read[$i]=$pos_sings[$i];
if (empty($pos_hunds[$i]) AND empty($pos_decs[$i]) AND empty($pos_sings[$i])) $read[$i]='';
switch($i) {
case 1: if ($pos[1]>1 OR $pos[2]>0 OR $pos[3]>0) $read[$i]=$read[$i]." лева"; else $read[$i]=$read[$i]." лев";break;
case 2: if($pos[2]>1) $read[$i]=$read[$i]." хиляди";break;
case 3: if ($pos[3]>1) $read[$i]=$read[$i]." милиона"; else if(!empty($pos[3])) $read[$i]=$read[$i]." милион";break;
}
}
if ($pos[1]=='000') $pos[1]=0;
if ($pos[2]=='000') $pos[2]=0;
if (!empty($pos[3]) AND !empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)==0) $ready=$read[3]." ".$read[2]." и ".$read[1];
if (!empty($pos[3]) AND !empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)>0) $ready=$read[3]." ".$read[2]." ".$read[1];
if (!empty($pos[3]) AND !empty($pos[2]) AND empty($pos[1]) AND substr($pos[2],-2,2)==0) $ready=$read[3]." и ".$read[2];
if (!empty($pos[3]) AND !empty($pos[2]) AND empty($pos[1]) AND substr($pos[2],-2,2)>0) $ready=$read[3]." ".$read[2];
if (!empty($pos[3]) AND empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)==0) $ready=$read[3]." и ".$read[1];
if (!empty($pos[3]) AND empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)>0) $ready=$read[3]." ".$read[1];
if (!empty($pos[3]) AND empty($pos[2]) AND empty($pos[1])) $ready=$read[3];
if (empty($pos[3]) AND !empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)==0) $ready=$read[2]." и ".$read[1];
if (empty($pos[3]) AND !empty($pos[2]) AND !empty($pos[1]) AND substr($pos[1],-2,2)>0) $ready=$read[2]." ".$read[1];
if (empty($pos[3]) AND !empty($pos[2]) AND empty($pos[1])) $ready=$read[2];
if (empty($pos[3]) AND empty($pos[2]) AND !empty($pos[1])) $ready=$read[1];
if (empty($pos[3]) AND empty($pos[2]) AND empty($pos[1])) $ready='';
if (empty($pos[1])) $ready=$ready." лева";
$ready=$ready." и $decimals ст.";
if (!empty($pos[1]) OR !empty($pos[2]) OR !empty($pos[3])) return $ready;
}

За времето, през което сме използвали този скрипт не е дал дефекти или грешки, но ако някой открие - да казва за да оправяме.


Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Чудя се може ли този код да се използва в MS Office Word и ако да как?

Всъщност имам нужда от нещо като Popup spell number for Word, само че да преобразува числата на български.

Ако някой се наеме да обясни работата с този код, моля ви много подробно, защото не съм запознат с VBА.

Благодаря!

Отваряш MS Word.

Щракваш Tools - Macro - Visual basic Editor.

Създаваш един нов модул : Insert - Module

Копираш кода и го поставяш в прозореца на модула.

Записваш го със Save.


Option Explicit

Dim warray(9) As String
Dim edin, edna, dwa, dwe, sto, dwesta, trista, stotin, deset, mil, mila, hil, hili, lw, st, i, jn, na
Dim C1, DS As String


Sub SpellNumber()
    MsgBox Num2Txt(Selection.Text), vbOKOnly, "Rsult"
End Sub

Function Conv(sstr As String) As String
Dim rstr, astrc, bstrc, cstrc
Dim apos, bpos, cpos

   If Len(sstr) = 3 Then
	 apos = Asc(Mid(sstr, 3, 1)) - Asc("0")
	 bpos = Asc(Mid(sstr, 2, 1)) - Asc("0")
	 cpos = Asc(Mid(sstr, 1, 1)) - Asc("0")
   Else
	 apos = Asc(Mid(sstr, 2, 1)) - Asc("0")
	 bpos = Asc(Mid(sstr, 1, 1)) - Asc("0")
	 cpos = 0
   End If

   If apos = 1 Then
	 If Len(sstr) = 3 Then
		 If C1 = 1 Then
		   astrc = warray(1) + na
		 Else
		   astrc = warray(1) + jn
		 End If
	 Else
	   astrc = warray(1) + na
	 End If
   Else
	 If apos = 2 Then
	   If Len(sstr) = 3 Then
		 If (C1 = 1) And (bpos <> 1) Then
		   astrc = warray(2) + "Е"
		 Else
		   astrc = warray(2) + "А"
		 End If
	   Else
		 astrc = warray(2) + "Е"
	   End If
	 Else
	   If (apos >= 3) And (apos <= 9) Then astrc = warray(apos)
	 End If
   End If
 
   If bpos = 1 Then
	  If apos = 1 Then
		 bstrc = astrc + "А" + deset
		 astrc = ""
	  Else
		 If apos = 0 Then
		    bstrc = deset
		    astrc = ""
		 Else
		    If (apos >= 2) And (apos <= 9) Then bstrc = astrc + na + deset
		    astrc = ""
		 End If
	  End If
   Else
	  If bpos = 2 Then
	    bstrc = warray(bpos) + "А" + deset
	  Else
	    If (bpos >= 3) And (bpos <= 9) Then bstrc = warray(bpos) + deset
	  End If
   End If
    
  Select Case cpos
	  Case 1
	    cstrc = sto
	  Case 2
	    cstrc = dwesta
	  Case 3
	    cstrc = trista
   Case Else
	  If (cpos >= 4) And (cpos <= 9) Then cstrc = warray(cpos) + stotin
   End Select

   rstr = astrc
   If Len(cstrc) > 0 Then
	  If Len(astrc) > 0 Then
		 If Len(bstrc) > 0 Then
		    rstr = cstrc + " " + bstrc + i + rstr
		 Else
		    rstr = cstrc + i + rstr
		 End If
	  Else
		 If Len(bstrc) > 0 Then
		    rstr = cstrc + i + bstrc
		 Else
		    rstr = cstrc
		 End If
	  End If
   Else
	  If Len(bstrc) > 0 Then
		 If Len(astrc) > 0 Then
		    rstr = bstrc + i + rstr
		 Else
		    rstr = bstrc
		 End If
	  End If
   End If

   Conv = rstr
 
End Function

Function Extract_Number_from_Text(Phrase As String) As Double
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim Temp As String
Length_of_String = Len(Phrase)
Temp = ""
For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = True Then
    Temp = Temp & Mid(Phrase, Current_Pos, 1)
 End If
Next Current_Pos
If Len(Temp) = 0 Then
    Extract_Number_from_Text = 0
Else
    Extract_Number_from_Text = CDbl(Temp)
End If
End Function

Function Num2Txt(instring As String) As String
Dim LastDelimiter As String, wstr As String, fstr As String, ostring As String, cstrc As String, tstr As String

    DS = "."

    warray(1) = "ЕД"
    warray(2) = "ДВ"
    warray(3) = "ТРИ"
    warray(4) = "ЧЕТИРИ"
    warray(5) = "ПЕТ"
    warray(6) = "ШЕСТ"
    warray(7) = "СЕДЕМ"
    warray(8) = "ОСЕМ"
    warray(9) = "ДЕВЕТ"

    jn = "ИН"
    na = "НА"
    sto = "СТО"
    dwesta = "ДВЕСТА"
    trista = "ТРИСТА"
    stotin = "СТОТИН"
    deset = "ДЕСЕТ"
    mil = "МИЛИОН"
    mila = " МИЛИОНА"
    hil = "ХИЛЯДА"
    hili = " ХИЛЯДИ"
    lw = " ЛВ."
    st = " СТ."
    i = " И "

wstr = Extract_Number_from_Text(instring)
LastDelimiter = InStr(1, wstr, DS)

If LastDelimiter > 0 Then
  fstr = Mid(wstr, LastDelimiter + 1, 2)
  wstr = Mid(wstr, 1, LastDelimiter - 1)
End If

If Len(fstr) < 2 Then
  fstr = fstr + Mid("00", 1, 2 - Len(fstr))
End If

ostring = ""
C1 = 0
Do While wstr <> ""

  If Len(wstr) < 3 Then
    wstr = Mid("000", 1, 3 - Len(wstr)) + wstr
  End If
  tstr = Mid(wstr, Len(wstr) - 2, 3)
  cstrc = Conv(tstr)

  Select Case C1
  Case 1
	 If (tstr = "001") Then
	   cstrc = hil
	 ElseIf cstrc <> "" Then
	    cstrc = cstrc + hili
	 End If
  Case 2
	 If (tstr = "001") Then
	   cstrc = warray(1) + jn + " " + mil
	 ElseIf cstrc <> "" Then
	   cstrc = cstrc + mila
	 End If
  End Select
 
  If Len(wstr) >= 3 Then
    wstr = Mid(wstr, 1, Len(wstr) - 3)
  Else
    wstr = ""
  End If
 
  If cstrc <> "" Then
	  If (C1 = 0) Then
	    If (wstr <> "") And (InStr(1, cstrc, i) = 0) Then
		  ostring = i + cstrc
	    Else
		  ostring = cstrc
	    End If
	  Else
	    ostring = cstrc + " " + ostring
	  End If
  End If

  C1 = C1 + 1
 
Loop

  If Len(fstr) > 0 Then
    If ostring <> "" Then
	  Num2Txt = ostring + lw + " И " + fstr + st
    Else
	  Num2Txt = fstr + st
    End If
  Else
    Num2Txt = ostring + lw
  End If

End Function

Маркираш число в MS Word и извикваш макроса SpellNumber.

Работи коректно, ако е маркирано валидно число.

Редактирано от Ken (преглед на промените)

Сподели този отговор


Линк към този отговор
Сподели в други сайтове

Регистрирайте се или влезете в профила си за да коментирате

Трябва да имате регистрация за да може да коментирате това

Регистрирайте се

Създайте нова регистрация в нашия форум. Лесно е!

Нова регистрация

Вход

Имате регистрация? Влезте от тук.

Вход

×

Информация

Поставихме бисквитки на устройството ви за най-добро потребителско изживяване. Можете да промените настройките си за бисквитки, или в противен случай приемаме, че сте съгласни с нашите условия за ползване.