Postada em 18/03/2013 10:03 hs
Uma bem eclética que dá pra usar com a unidade que quiser.
Private Sub Command1_Click()
'lblExtenso = Extenso(txtValor.Text, "Reais", "Real", "Centavos", "Centavo")
'lblExtenso = Extenso(txtValor.Text, "Metros", "Metro", "Centímetros", "Centimetro")
lblExtenso = Extenso(txtValor.Text, "Metros²", "Metro²", "Centímetros²", "Centimetro²")
End Sub
Public Function Extenso(ByVal Valor As Double, ByVal MoedaPlural As String, ByVal MoedaSingular As String, ByVal DecimalPlural As String, ByVal DecimalSingular 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, "", "", "", "")
If Extenso <> vbNullString Then
Extenso = Extenso & " e " & buf & IIf(Parcial > 1, DecimalPlural, DecimalSingular)
End If
'Extenso = Extenso & buf
End If
End If
End Function
|
