Премини към съдържанието
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 (преглед на промените)

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


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

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

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

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

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

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

    Вход

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

    Вход


    ×

    Информация

    Този сайт използва бисквитки (cookies), за най-доброто потребителско изживяване. С използването му, вие приемате нашите Условия за ползване.