Ler numero por extenso

[escorpion]

alguem me pode ajudar sobre codigo em vb para colocar em pagina excel para quando introduzir um numero aparecer a leitura desse numero por extenso..por exemplo se colocar numa célula "1043"

aparecer noutra " mil e quarenta e três"
obrigado

[[PT]CableGuy]

Encontrei dois exemplos:

1º:

Código: Seleccionar todos

Namespace Proteans.Utils.Conversion
Public Class ConvertMoney
Private m_19AndUnder(19) As String
Private m_Tens(9) As String
Private m_Hundred As String
Private m_Groups(10) As String
Private m_Dollar As String
Private m_Dollars As String
Private m_NoCents As String
Private m_Cent As String
Private m_Cents As String
Private m_Hyphen As String
Private m_And As String
Private m_InvalidAmount As String

Public Sub New()
'Initialize all the "words"
m_19AndUnder(0) = "Zero"
m_19AndUnder(1) = "One"
m_19AndUnder(2) = "Two"
m_19AndUnder(3) = "Three"
m_19AndUnder(4) = "Four"
m_19AndUnder(5) = "Five"
m_19AndUnder(6) = "Six"
m_19AndUnder(7) = "Seven"
m_19AndUnder(8) = "Eight"
m_19AndUnder(9) = "Nine"
m_19AndUnder(10) = "Ten"
m_19AndUnder(11) = "Eleven"
m_19AndUnder(12) = "Twelve"
m_19AndUnder(13) = "Thirteen"
m_19AndUnder(14) = "Fourteen"
m_19AndUnder(15) = "Fifteen"
m_19AndUnder(16) = "Sixteen"
m_19AndUnder(17) = "Seventeen"
m_19AndUnder(18) = "Eighteen"
m_19AndUnder(19) = "Nineteen"

m_Tens(2) = "Twenty"
m_Tens(3) = "Thirty"
m_Tens(4) = "Forty"
m_Tens(5) = "Fifty"
m_Tens(6) = "Sixty"
m_Tens(7) = "Seventy"
m_Tens(8) = "Eighty"
m_Tens(9) = "Ninety"

m_Hundred = "Hundred"

m_Groups(1) = ""
m_Groups(2) = "Thousand"
m_Groups(3) = "Million"
m_Groups(4) = "Billion"
m_Groups(5) = "Trillion"
m_Groups(6) = "Quadrillion"
m_Groups(7) = "Quintillion"
m_Groups(8) = "Sextillion"
m_Groups(9) = "Septillion"
m_Groups(10) = "Octillion"

m_Dollar = " Dollar"
m_Dollars = " Dollars"

m_NoCents = "No Cents"
'm_Cent & m_Cents could both be changed to "/100"
m_Cent = " Cent"
m_Cents = " Cents"

'Used for #s like: 23 = "Twenty-Three"
m_Hyphen = "-"

'Used between dollars & cents: "One Dollar and 12 Cents"
m_And = " and "

m_InvalidAmount = "Invalid Dollar Amount."
End Sub

Public Function MonetaryToWords(ByVal Value As Object) As String
Dim decValue As Object
Dim sValue As String
Dim iDecimal As Integer
Dim sCents As String
Dim sDollars As String

'Convert input into a Decimal value (up to 28 digits)
decValue = CDec(Value)
If decValue < 0 Then GoTo ER

'Convert the Decimal value back into a string. This eliminates
' any format characters such as "$" or ",".
sValue = CStr(decValue)

'Find the decimal point & extract the dollars from the cents
iDecimal = InStr(1, sValue, ".")
If iDecimal = 0 Then
sDollars = sValue
sCents = "00"
Else
'Extract decimal value
sCents = Mid$(sValue, iDecimal + 1)
If Len(sCents) > 2 Then GoTo ER

'Extract dollars
sDollars = Left$(sValue, iDecimal - 1)

'Fill-out decimal places to two digits
sCents = Left$(sCents & "00", 2)
End If

'At this point,
' sDollars = the whole dollar value (0.. approx 79 Octillion)
' sCents = the cents (00..99)

Debug.Assert(Len(sCents) = 2)
Debug.Assert(Len(sDollars) > 0)
Debug.Assert(Len(sDollars) < 31)

Select Case sCents
Case "00"
sCents = m_NoCents

Case "01"
sCents = sCents & m_Cent

Case Else
sCents = sCents & m_Cents
End Select

MonetaryToWords = DollarsToWords(sDollars) & m_And & sCents

Exit Function

ER:

MonetaryToWords = m_InvalidAmount
End Function

Private Function DollarsToWords(ByVal sDollars As String) As String
Dim sWords As String
Dim decValue As Object
Dim sRemaining As String
Dim s3Digits As String
Dim iGroup As Integer
Dim i100s As Integer
Dim i10s As Integer
Dim i1s As Integer
Dim i99OrLess As Integer
Dim sWork As String

'We had better be passing a valid number
Debug.Assert(IsNumeric(sDollars))

'Check for special cases. This also serves to validate the value
decValue = CDec(sDollars)
Select Case decValue
Case 0
DollarsToWords = m_19AndUnder(decValue) & m_Dollars
Exit Function

Case 1
DollarsToWords = m_19AndUnder(decValue) & m_Dollar
Exit Function

End Select

'There should be no insignificant zeroes, "punctuation" or decimals
Debug.Assert(sDollars = CStr(decValue))

iGroup = 0
sRemaining = sDollars
sWords = ""

'Extract each group of three digits, convert to words and prefix to result
While Len(sRemaining) > 0
iGroup = iGroup + 1

'Extract next group of three digits
If Len(sRemaining) > 3 Then
s3Digits = Right$(sRemaining, 3)
sRemaining = Left$(sRemaining, Len(sRemaining) - 3)
Else
'Fill-out group to three digits
s3Digits = Right$("00" & sRemaining, 3)
sRemaining = ""
End If

Debug.Assert(Len(s3Digits) = 3)

If s3Digits <> "000" Then
i100s = CInt(Left$(s3Digits, 1))
i10s = CInt(Mid$(s3Digits, 2, 1))
i1s = CInt(Right$(s3Digits, 1))
i99OrLess = (i10s * 10) + i1s
sWork = " " & m_Groups(iGroup)

Select Case True
'Do we have 20..99?
Case i10s > 1
Debug.Assert(i10s <= 9)

If i1s > 0 Then
Debug.Assert(i1s <= 9)

sWork = m_Tens(i10s) & m_Hyphen & m_19AndUnder(i1s) & sWork
Else
sWork = m_Tens(i10s) & sWork
End If

'Do we have 01..19?
Case i99OrLess > 0
Debug.Assert(i99OrLess <= 99)

sWork = m_19AndUnder(i99OrLess) & sWork

Case Else
'If we're here, it's because there are no tens or ones
Debug.Assert(i99OrLess = 0)
Debug.Assert(i10s = 0)
Debug.Assert(i1s = 0)
Debug.Assert(Right$(s3Digits, 2) = "00")

'If there's no tens or ones, there better be hundreds
Debug.Assert(i100s > 0)

End Select

If i100s > 0 Then
Debug.Assert(i100s <= 9)

sWork = m_19AndUnder(i100s) & " " & m_Hundred & " " & sWork
End If

Debug.Assert(Len(Trim$(sWork)) > 0)

sWords = sWork & " " & sWords
End If
End While

DollarsToWords = Trim$(sWords) & m_Dollars
End Function


End Class

2º:
Numbers-to-Text (VB Code) - Download

[escorpion]

muito obrigado...entretanto encontrei em portugues



Public Function Extenso(ByVal Valor As _
Double, ByVal MoedaPlural As _
String, ByVal MoedaSingular As _
String) As String
Dim StrValor As String, Negativo As Boolean
Dim Buf As String, Parcial As Integer
Dim Posicao As Integer, Unidades
Dim Dezenas, Centenas, PotenciasSingular
Dim PotenciasPlural

Negativo = (Valor < 0)
Valor = Abs(CDec(Valor))
If Valor Then
Unidades = Array(vbNullString, "Um", "Dois", _
"Três", "Quatro", "Cinco", _
"Seis", "Sete", "Oito", "Nove", _
"Dez", "Onze", "Doze", "Treze", _
"Quatorze", "Quinze", "Dezesseis", _
"Dezessete", "Dezoito", "Dezenove")
Dezenas = Array(vbNullString, vbNullString, _
"Vinte", "Trinta", "Quarenta", _
"Cinqüenta", "Sessenta", "Setenta", _
"Oitenta", "Noventa")
Centenas = Array(vbNullString, "Cento", _
"Duzentos", "Trezentos", _
"Quatrocentos", "Quinhentos", _
"Seiscentos", "Setecentos", _
"Oitocentos", "Novecentos")
PotenciasSingular = Array(vbNullString, " Mil", _
" Milhão", " Bilhão", _
" Trilhão", " Quatrilhão")
PotenciasPlural = Array(vbNullString, " Mil", _
" Milhões", " Bilhões", _
" Trilhões", " Quatrilhões")

StrValor = Left(Format(Valor, String(18, "0") & _
".000"), 18)
For Posicao = 1 To 18 Step 3
Parcial = Val(Mid(StrValor, Posicao, 3))
If Parcial Then
If Parcial = 1 Then
Buf = "Um" & PotenciasSingular((18 - _
Posicao) \ 3)
ElseIf Parcial = 100 Then
Buf = "Cem" & PotenciasSingular((18 - _
Posicao) \ 3)
Else
Buf = Centenas(Parcial \ 100)
Parcial = Parcial Mod 100
If Parcial <> 0 And Buf <> vbNullString Then
Buf = Buf & " e "
End If
If Parcial < 20 Then
Buf = Buf & Unidades(Parcial)
Else
Buf = Buf & Dezenas(Parcial \ 10)
Parcial = Parcial Mod 10
If Parcial <> 0 And Buf <> vbNullString Then
Buf = Buf & " e "
End If
Buf = Buf & Unidades(Parcial)
End If
Buf = Buf & PotenciasPlural((18 - Posicao) \ 3)
End If
If Buf <> vbNullString Then
If Extenso <> vbNullString Then
Parcial = Val(Mid(StrValor, Posicao, 3))
If Posicao = 16 And (Parcial < 100 Or _
(Parcial Mod 100) = 0) Then
Extenso = Extenso & " e "
Else
Extenso = Extenso & ", "
End If
End If
Extenso = Extenso & Buf
End If
End If
Next
If Extenso <> vbNullString Then
If Negativo Then
Extenso = "Menos " & Extenso
End If
If Int(Valor) = 1 Then
Extenso = Extenso & " " & MoedaSingular
Else
Extenso = Extenso & " " & MoedaPlural
End If
End If
Parcial = Int((Valor - Int(Valor)) * _
100 + 0.1)
If Parcial Then
Buf = Extenso(Parcial, "Centavos", _
"Centavo")
If Extenso <> vbNullString Then
Extenso = Extenso & " e "
End If
Extenso = Extenso & Buf
End If
End If
End Function