Adicione um módulo ao Projeto e ponha nele a seguinte função:
Public Function VALOREXTENSO(NUMERO As Currency) As String
If IsNull(NUMERO) Or NUMERO = 0 Then
VALOREXTENSO = "Numero Faltando ou igual a zero"
Exit Function
End If
If NUMERO > 99000# Then
MsgBox "O Valor máximo para conversão por extenso é R$ 99.000,00 !", vbInformation, "Número muito alto"
VALOREXTENSO = "Número excede a faixa..."
Exit Function
End If
Dim U(1 To 9) As String 'Unidades (1 - 9)
U(1) = "um"
U(2) = "dois"
U(3) = "três"
U(4) = "quatro"
U(5) = "cinco"
U(6) = "seis"
U(7) = "sete"
U(8) = "oito"
U(9) = "nove"
Dim DD(1 To 9) As String 'Dez e ... (11 - 19)
DD(1) = "onze"
DD(2) = "doze"
DD(3) = "treze"
DD(4) = "quatorze"
DD(5) = "quinze"
DD(6) = "dezesseis"
DD(7) = "dezessete"
DD(8) = "dezoito"
DD(9) = "dezenove"
Dim D(1 To 10) As String 'Dezenas (10,20,30, ..., 100)
D(1) = "dez"
D(2) = "vinte"
D(3) = "trinta"
D(4) = "quarenta"
D(5) = "cinqüenta"
D(6) = "sessenta"
D(7) = "setenta"
D(8) = "oitenta"
D(9) = "noventa"
D(10) = "cem"
Dim C(1 To 10) As String 'Centenas (100,200, ..., 1.000)
C(1) = "cento"
C(2) = "duzentos"
C(3) = "trezentos"
C(4) = "quatrocentos"
C(5) = "quinhentos"
C(6) = "seiscentos"
C(7) = "setecentos"
C(8) = "oitocentos"
C(9) = "novecentos"
C(10) = "mil"
Dim TEXTO As String 'Variável utilizada para montar e armazenar o valor por extenso
TEXTO = ""
Dim StrNUMERO As String 'Vairável utilizada para armazenar o valor em forma de string
StrNUMERO = Str(NUMERO)
Dim TamNUMERO As Integer 'Tamanho do Número
Dim PI, PF As Integer 'Variáveis utilizadas em subrotinas de milhares
If InStr(1, StrNUMERO, ".", vbTextCompare) > 0 Then 'Se existe casas decimais
Dim DEC As String
DEC = Right(StrNUMERO, 2) 'Extraindo os dois último valores
If InStr(1, DEC, ".", vbTextCompare) > 0 Then 'Se apenas 1 casa decimal acrescente 0
DEC = Right(DEC, 1) & "0" 'Acrescentando 0
StrNUMERO = Str(Int(Val(StrNUMERO))) & "." & Trim(DEC) 'Atualizando as casas decimais
End If
Else
StrNUMERO = StrNUMERO & ".00" 'Acrescentando 00
End If
If Int(Val(StrNUMERO)) = 0 Then
StrNUMERO = "0" & Trim(StrNUMERO)
End If
TamNUMERO = Len(Trim(StrNUMERO))
'Centavos
Dim X1, X2, X3 As Integer
X1 = Val(Right(StrNUMERO, 2))
X2 = Val(Left(Trim(Str(X1)), 1)) ' 1 Casa decimal
X3 = Val(Right(Trim(Str(X1)), 1)) '2º Casa decimal
If X1 > 0 Then 'Existe centavos
If X1 = 1 Then
TEXTO = "um centavo"
Else
If X1 < 11 Then 'Entre 2 e 10
If X1 = 10 Then 'Dez
TEXTO = "dez centavos"
Else
TEXTO = U(X3) & " centavos"
End If
ElseIf X1 > 10 And X1 < 20 Then 'Entre 11 e 19
TEXTO = DD(X3) & " centavos"
ElseIf X1 = 20 Or X1 = 30 Or X1 = 40 Or X1 = 50 Or X1 = 60 Or X1 = 70 Or X1 = 80 Or X1 = 90 Then
TEXTO = D(X2) & " centavos"
Else 'Valores entre 21 e 99 exceto os redondos (20, 30, etc...)
TEXTO = D(X2) & " e " & U(X3) & " centavos"
End If
End If
Else 'Não existe centavos
TEXTO = ""
End If
'REAIS
'Unidades e Dezenas
Dim DEZ, DEZ1, DEZ2 As Integer
Dim strDEZ As String
DEZ = Int(Val(StrNUMERO))
strDEZ = Trim(Str(DEZ))
DEZ = Val(Right(strDEZ, 2))
strDEZ = IIf(Len(strDEZ) = 1, "0" & strDEZ, strDEZ)
DEZ1 = Val(Mid(Trim(strDEZ), (Len(Trim(strDEZ)) - 1), 1))
DEZ2 = Val(Right(strDEZ, 1))
If DEZ = 10 Or DEZ = 20 Or DEZ = 30 Or DEZ = 40 Or DEZ = 50 Or DEZ = 60 Or DEZ = 70 Or DEZ = 80 Or DEZ = 90 Then
If Len(Trim(TEXTO)) > 0 Then
TEXTO = D(DEZ1) & " reais e " & TEXTO
Else
TEXTO = D(DEZ1) & " reais"
End If
ElseIf DEZ > 0 And DEZ < 10 Then 'Entre 1 e 9 reais
If DEZ = 1 Then
TEXTO = IIf(Len(Trim(TEXTO)) = 0, "um real", U(DEZ2) & " real e " & TEXTO)
Else
TEXTO = IIf(Len(Trim(TEXTO)) = 0, U(DEZ2) & " reais", U(DEZ2) & " reais e " & TEXTO)
End If
ElseIf DEZ > 10 And DEZ < 20 Then 'Entre 11 e 19
TEXTO = IIf(Len(Trim(TEXTO)) = 0, DD(DEZ2) & " reais", DD(DEZ2) & " reais e " & TEXTO)
Else 'Valores entre 21 e 99 exceto os inteiros (20,30, etc...)
If DEZ > 0 Then TEXTO = IIf(Len(Trim(TEXTO)) = 0, D(DEZ1) & " e " & U(DEZ2) & " reais", D(DEZ1) & " e " & U(DEZ2) & " reais e " & TEXTO)
End If
'Centenas
Dim CEM, CEM1, CEM2 As Integer
Dim StrCEM As String
CEM = Int(Val(StrNUMERO))
If CEM > 99 Then 'Se existir centenas
CEM = (CEM - DEZ) / 100
If CEM > 9 Then 'Existe milhar(es)
CEM = Val(Right(Str(CEM), 1))
End If
If CEM = 1 Then
If DEZ > 0 Then
TEXTO = C(CEM) & " e " & TEXTO
Else
TEXTO = IIf(Len(Trim(TEXTO)) = 0, "cem reais", C(CEM) & " reais e " & TEXTO)
End If
ElseIf CEM > 1 Then
If DEZ > 0 Then
TEXTO = C(CEM) & " e " & TEXTO
Else
TEXTO = IIf(Len(Trim(TEXTO)) = 0, C(CEM) & " reais", C(CEM) & " reais e " & TEXTO)
End If
End If
End If
'Unidades e Dezenas de Milhar
Dim MIL As Currency
MIL = Int(Val(StrNUMERO))
If MIL >= 1000 Then 'Existe Milhar
If CEM > 0 Then MIL = MIL - CEM
If DEZ > 0 Then MIL = MIL - DEZ
MIL = Int(MIL / 1000)
Dim MIL1, MIL2 As Integer
Dim strMIL As String
strMIL = Trim(Str(MIL))
MIL1 = Val(Left(MIL, 1))
MIL2 = Val(Right(MIL, 1))
If MIL = 1 Then
If Len(Trim(TEXTO)) > 0 Then 'Existe valores inferiores a mil
If InStr(1, TEXTO, "rea", vbTextCompare) > 0 Then 'já existe reais
PI = InStr(1, TEXTO, "real", vbTextCompare)
PF = InStr(1, TEXTO, "real", vbTextCompare) + 3
If PI > 0 Then
If InStr(1, TEXTO, "centavo", vbTextCompare) > 0 Then 'tem centavos
TEXTO = "hum mil e " & Left(TEXTO, PI - 1) & "reais" & Right(TEXTO, Len(TEXTO) - PF)
Else
TEXTO = "hum mil e " & Left(TEXTO, (PI - 1)) & "reais"
End If
Else
TEXTO = "hum mil e " & TEXTO
End If
Else 'só existe centavos
TEXTO = "hum mil reais e " & TEXTO
End If
Else
TEXTO = "hum mil reais"
End If
ElseIf MIL > 1 And MIL < 10 Then 'Casa de milhar entre 2000 e 9000
If Len(Trim(TEXTO)) > 0 Then 'Existe valores inferiores a mil
If InStr(1, TEXTO, "rea", vbTextCompare) > 0 Then 'já existe reais
PI = InStr(1, TEXTO, "real", vbTextCompare)
PF = InStr(1, TEXTO, "real", vbTextCompare) + 3
If PI > 0 Then
If InStr(1, TEXTO, "centavo", vbTextCompare) > 0 Then 'tem centavos
TEXTO = U(MIL2) & " mil e " & Left(TEXTO, PI - 1) & "reais" & Right(TEXTO, Len(TEXTO) - PF)
Else
TEXTO = U(MIL2) & " mil e " & Left(TEXTO, (PI - 1)) & "reais"
End If
Else
TEXTO = U(MIL2) & " mil e " & TEXTO
End If
Else 'só existe centavos
TEXTO = U(MIL2) & " mil reais e " & TEXTO
End If
Else
TEXTO = U(MIL2) & " mil reais"
End If
ElseIf MIL = 20 Or MIL = 30 Or MIL = 40 Or MIL = 50 Or MIL = 60 Or MIL = 70 Or MIL = 80 Or MIL = 90 Then 'Valores redondos 20mil, 30mil, etc..
If Len(Trim(TEXTO)) > 0 Then 'Existe valores inferiores a mil
If InStr(1, TEXTO, "rea", vbTextCompare) > 0 Then 'já existe reais
PI = InStr(1, TEXTO, "real", vbTextCompare)
PF = InStr(1, TEXTO, "real", vbTextCompare) + 3
If PI > 0 Then
If InStr(1, TEXTO, "centavo", vbTextCompare) > 0 Then 'tem centavos
TEXTO = D(MIL1) & " mil e " & Left(TEXTO, PI - 1) & "reais" & Right(TEXTO, Len(TEXTO) - PF)
Else
TEXTO = D(MIL1) & " mil e " & Left(TEXTO, (PI - 1)) & "reais"
End If
Else
TEXTO = D(MIL1) & " mil e " & TEXTO
End If
Else 'só existe centavos
TEXTO = D(MIL1) & " mil reais e " & TEXTO
End If
Else
TEXTO = D(MIL1) & " mil reais"
End If
ElseIf MIL > 10 And MIL < 20 Then 'Valores entre 11 e 19 mil
If Len(Trim(TEXTO)) > 0 Then 'Existe valores inferiores a mil
If InStr(1, TEXTO, "rea", vbTextCompare) > 0 Then 'já existe reais
PI = InStr(1, TEXTO, "real", vbTextCompare)
PF = InStr(1, TEXTO, "real", vbTextCompare) + 3
If PI > 0 Then
If InStr(1, TEXTO, "centavo", vbTextCompare) > 0 Then 'tem centavos
TEXTO = DD(MIL2) & " mil e " & Left(TEXTO, PI - 1) & "reais" & Right(TEXTO, Len(TEXTO) - PF)
Else
TEXTO = DD(MIL2) & " mil e " & Left(TEXTO, (PI - 1)) & "reais"
End If
Else
TEXTO = DD(MIL2) & " mil e " & TEXTO
End If
Else 'só existe centavos
TEXTO = DD(MIL2) & " mil reais e " & TEXTO
End If
Else
TEXTO = DD(MIL2) & " mil reais"
End If
Else
If Len(Trim(TEXTO)) > 0 Then 'Existe valores inferiores a mil
If InStr(1, TEXTO, "rea", vbTextCompare) > 0 Then 'já existe reais
PI = InStr(1, TEXTO, "real", vbTextCompare)
PF = InStr(1, TEXTO, "real", vbTextCompare) + 3
If PI > 0 Then
If InStr(1, TEXTO, "centavo", vbTextCompare) > 0 Then 'tem centavos
TEXTO = D(MIL1) & " e " & U(MIL2) & " mil e " & Left(TEXTO, PI - 1) & "reais" & Right(TEXTO, Len(TEXTO) - PF)
Else
TEXTO = D(MIL1) & " e " & U(MIL2) & " mil e " & Left(TEXTO, (PI - 1)) & "reais"
End If
Else
TEXTO = D(MIL1) & " e " & U(MIL2) & " mil e " & TEXTO
End If
Else 'só existe centavos
TEXTO = D(MIL1) & " e " & U(MIL2) & " mil reais e " & TEXTO
End If
Else
TEXTO = D(MIL1) & " e " & U(MIL2) & " mil reais"
End If
End If
End If
VALOREXTENSO = TEXTO
End Function
Agora insira 2 Textbox'sNo text1 ponha no envento lostFocus:
Pergunta
Macêdo
Adicione um módulo ao Projeto e ponha nele a seguinte função:
Agora insira 2 Textbox's No text1 ponha no envento lostFocus:Pronto!
Editado por kuroiTag CODE
Link para o comentário
Compartilhar em outros sites
0 respostass a esta questão
Posts Recomendados
Participe da discussão
Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.