Buongiorno,
attualmente uso questa funzione IN MODULI per convertire i numeri in lettere:
Option Compare Database
Option Explicit
'///////////////////////////////////////////////////////////////////////////////
'// //
'// PROJECT : //
'// FILE : cur2str.bas //
'// VERSION : 1.0.0 //
'// CREATED : 01/09/1998 BY : Roal Zanazzi //
'// LAST MODIF. : 18/12/1998 BY : Alessandro Scardova //
'// LANGUAGE : Visual Basic 6.0 //
'// ENVIRONMENT : Windows 95/NT 4.0 //
'// DESCRIPTION : LongCur2Str() function converts a Currency variant into its //
'// textual representation (i.e. 1234 -> OneThousandTwoHundredThirtyFour). //
'// The resulting text can be in any of the supported languages: //
'// Italian, English, French, German.
'// EuroCheques() Function Allow to make a cheque in Euro Currency.
'// //
'// Copyright © 1998 Roal Zanazzi <zrs@iol.it> //
'///////////////////////////////////////////////////////////////////////////////
'Adattato per MSAccess97 da Federico Luciani
Const langItalian = 1
Const langEnglish = 2
Const langFrench = 3
Const langGerman = 4
Private Function LongCur2Str(ByVal cValue As Currency, ByRef sCaseValue As String, Optional ByVal Language As Byte) As Long
Const MAXLEN = 12 'DON'T CHANGE!
Dim StartValue As String, _
strValue As String, _
strResult As String
Dim n100 As Integer ' x00
Dim n10 As Integer ' 0x0
Dim n1 As Integer ' 00x
Dim i As Integer ' Counter in For..Next loop.
Dim sNumberStrings As Variant
If IsEmpty(Language) Then Language = langItalian
Select Case Language
Case langItalian
sNumberStrings = Array _
("zero", "uno", "due", "tre", "quattro", "cinque", "sei", "sette", "otto", "nove", _
"dieci", "undici", "dodici", "tredici", "quattordici", "quindici", "sedici", "diciassette", "diciotto", "diciannove", _
"venti", "trenta", "quaranta", "cinquanta", "sessanta", "settanta", "ottanta", "novanta", _
"cento", "duecento", "trecento", "quattrocento", "cinquecento", "seicento", "settecento", "ottocento", "novecento", _
"mille", "mila", "unmilione", "milioni", "unmiliardo", "miliardi", "** Valore non calcolabile **")
Case langEnglish
sNumberStrings = Array _
("Zero", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", _
"Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen", _
"Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety", _
"Onehundred", "Twohundred", "Threehundred", "Fourhundred", "Fivehundred", "Sixhundred", "Sevenhundred", "Eighthundred", "Ninehundred", _
"Onethousand", "Thousand", "OneMillion", "Millions", "OneBillion", "Billions", "** Value not calculable **")
Case langFrench
sNumberStrings = Array _
("Zero", "Un", "Deux", "Trois", "Quatre", "Cinq", "Six", "Sept", "Huit", "Neuf", _
"Dix", "Onze", "Douze", "Treize", "Quatorze", "Quinze", "Seize", "Dixsept", "Dixhuit", "Dixneuf", _
"Vingt", "Trente", "Quarante", "Cinquante", "Soixante", "Soixantedix", "Quatrevingts", "Quatrevingtdix", _
"Cent", "Deuxcents", "Troiscents", "Quatrecents", "Cinqcents", "Sixcents", "Septcents", "Huitcents", "Neufcents", _
"Mille", "Mille", "UnMillion", "Million", "UnMilliard", "Milliard", "** Valeur pas calculable **")
Case langGerman
sNumberStrings = Array _
("Null", "Ein", "Zwei", "Drei", "Vier", "Fünf", "Sechs", "Sieben", "Acht", "Neun", _
"Zehn", "Elf", "Zwölf", "Dreizehn", "Vierzehn", "Fünfzehn", "Sechzehn", "Siebzehn", "Achtzehn", "Neunzehn", _
"Zwanzig", "Dreißig", "Vierzig", "Fünfzig", "Sechzig", "Siebzig", "Achtzig", "Neunzig", _
"Hundert", "Zweihundert", "Dreihundert", "Vierhundert", "Fünfhundert", "Sechshundert", "Siebenhundert", "Achthundert", "Neunhundert", _
"Tausend", "Tausend", "EineMillion", "Millionen", "EineMilliarde", "Milliarden", "** Unberechenbarer Wert **")
End Select
' Controlli iniziali
' (gestisce fino a 999.999.999.999)
If cValue > 999999999999# Then
sCaseValue = sNumberStrings(43)
LongCur2Str = 1 'OwerflowError
Exit Function
End If
If cValue = 0 Then
sCaseValue = sNumberStrings(0)
LongCur2Str = 0
Exit Function
End If
StartValue = Format(cValue, String(MAXLEN, "0"))
strResult = ""
' Inizio conversione
For i = 1 To (MAXLEN \ 3)
strValue = Mid$(StartValue, i * 3 - 2, 3)
n100 = Val(Mid$(strValue, 1, 1))
n10 = Val(Mid$(strValue, 2, 1))
n1 = Val(Mid$(strValue, 3, 1))
' ----- Centinaia
If (n100 > 0) Then strResult = strResult & sNumberStrings(n100 + 27)
' ----- Decine e Unita'
' Tratta in modo differente i numeri [1..9], [10..19], [20..99].
If (n10 = 0) Then '[1..9]
If (n1 > 0) Then strResult = strResult & sNumberStrings(n1)
ElseIf (n10 = 1) Then '[10..19]
strResult = strResult & sNumberStrings(10 + n1)
Else 'If (n10 > 1) Then '[20..99]
If ((Language = langGerman) And (n1 <> 0)) Then
' TEDESCO: un numero compreso tra 21 e 99 non terminante con
' 0, si scrive prima il numero che indica le unità, poi "und" ("e" in
' tedesco) e poi il numero che indica le decine, tutto attaccato
strResult = strResult & sNumberStrings(n1) & "Und" & sNumberStrings(n10 + 18)
Else
strResult = strResult & sNumberStrings(n10 + 18)
' ITALIANO: correzione per decine con unita' = 1 o 8;
' troncamento dell'ultima vocale delle decine: VentiUno -> VentUno
If (Language = langItalian) Then
If ((n1 = 1) Or (n1 = 8)) Then strResult = Left(strResult, Len(strResult) - 1)
End If
' ----- Unita' (solo se le decine<>10)
If ((n1 > 0) And (n10 <> 1)) Then strResult = strResult & sNumberStrings(n1)
End If
End If
' Ultimi aggiustamenti
' Aggiunge Miliardi, Milioni e Mila (oppure 1Miliardo, 1Milione, Mille).
If (i < 4) Then
If (strValue = "001") Then ' 1000
strResult = Left(strResult, Len(strResult) - Len(sNumberStrings(1)))
strResult = strResult & sNumberStrings(44 - (i * 2) - 1)
ElseIf (strValue <> "000") Then ' x000
strResult = strResult & sNumberStrings(44 - (i * 2))
End If
End If
Next
' TEDESCO: se l'ultima cifra e' 1, si scrive Eins, non Ein.
If (Language = langGerman) Then
If (Right(strResult, 3) = sNumberStrings(1)) Then strResult = strResult & "s"
End If
sCaseValue = strResult
LongCur2Str = 0
End Function
Public Function EuroCheque(ByVal vValue As Variant, ByRef sNumberValue As String, ByRef sCaseValue As String, Optional ByVal Language As Byte) As Long
On Error GoTo EuroChequeError
Dim sTempCaseValue As String
'Controlli su vValue
If IsNull(vValue) Then GoTo EuroChequeError
If vValue = vbNullString Then GoTo EuroChequeError
If Not IsNumeric(vValue) Then GoTo EuroChequeError
If LongCur2Str(CCur(Int(vValue)), sTempCaseValue, Language) Then GoTo EuroChequeError
sCaseValue = StrConv(sTempCaseValue & "/" & Right$(Format$(vValue, ".00"), 2), vbProperCase)
sNumberValue = Format$(vValue, "#,##0.00")
Exit Function
EuroChequeError:
sNumberValue = "Error"
sCaseValue = "Error"
EuroCheque = 1
End Function
Public Function Converti(Valore As Variant)
Dim Risu As String
' Si deve separare la parte intera da quella decimale ed usiamo le funzioni matematiche
Dim p_intera As Integer
Dim p_decimale As Integer
' prelievo della parte intera
p_intera = Fix(Valore)
' prelievo delle due cifre decimali con approssimazione.
p_decimale = Fix(((Valore - p_intera) * 100) + 0.5)
' Composizione del risultato
LongCur2Str p_intera, Risu, langItalian
' Parte dei decimali
If p_decimale > 0 Then
Converti = Risu & "/" & Format(CStr(p_decimale), "00")
Else
Converti = Risu & "/00"
End If
End Function
Non capisco come mai superata la cifra di 32.800,00 euro mi da errore RUNTIME 6 OverFLOW nella riga:
p_intera = Fix(Valore)
Se invece cerco di convertire la cifra di 32.750,00 me la converte senza problemi.
Avete suggerimenti?