[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

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

[bti]

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

[maxim4o]

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