[Resolvido]número por extenso

Bom dia, amigos deste forum,

Estou precisando de um código ou dll, "Não sei qual solução, que atende",
que converta números inteiros em escrita por extenso.

Se possível com em Reais e centavos.

Grato,

Campos.

Bom dia...

Crie uma caixa de texto com o nome...txtextenso, digite o código dentro dela...=ExtensoHum([maodeobra];Falso;Falso)

Insira um módulo e insira esse código:

Código:


Public Function ExtensoX(nValor As String) As String
On Error GoTo Sai
    
    If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function

Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String
Dim strUnid(19) As String

    strUnid(1) = "um "
    strUnid(2) = "dois "
    strUnid(3) = "três "
    strUnid(4) = "quatro "
    strUnid(5) = "cinco "
    strUnid(6) = "seis "
    strUnid(7) = "sete "
    strUnid(8) = "oito "
    strUnid(9) = "nove "
    strUnid(10) = "dez "
    strUnid(11) = "onze "
    strUnid(12) = "doze "
    strUnid(13) = "treze "
    strUnid(14) = "quatorze "
    strUnid(15) = "quinze "
    strUnid(16) = "dezesseis "
    strUnid(17) = "dezessete "
    strUnid(18) = "dezoito "
    strUnid(19) = "dezenove "

Dim strDezena(9) As String
    strDezena(1) = "dez "
    strDezena(2) = "vinte "
    strDezena(3) = "trinta "
    strDezena(4) = "quarenta "
    strDezena(5) = "cinqüenta "
    strDezena(6) = "sessenta "
    strDezena(7) = "setenta "
    strDezena(8) = "oitenta "
    strDezena(9) = "noventa "

Dim strCentena(9) As String
    strCentena(1) = "cento "
    strCentena(2) = "duzentos "
    strCentena(3) = "trezentos "
    strCentena(4) = "quatrocentos "
    strCentena(5) = "quinhentos "
    strCentena(6) = "seiscentos "
    strCentena(7) = "setecentos "
    strCentena(8) = "oitocentos "
    strCentena(9) = "novecentos "

    strValor = Format$(nValor, "0000000000.00")
    strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
    strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
    strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
    strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
    For intContador = 1 To 4
        strParte = strGrupo(intContador)
        intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
        If intTamanho = 3 Then
            If Right$(strParte, 2) <> "00" Then
                strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
                intTamanho = 2
            Else
                strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
            End If
        End If

        If intTamanho = 2 Then
            If Val(Right(strParte, 2)) < 20 Then
                strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
            Else
                strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
                If Right$(strParte, 1) <> "0" Then
                    strTexto(intContador) = strTexto(intContador) + "e "
                    intTamanho = 1
                End If
            End If
        End If

        If intTamanho = 1 Then
            strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
        End If
    Next intContador

'Gera o formato final do texto
    If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
    Else
        strFinal = ""
        If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
        End If
        If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
        End If
        If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
        End If
        If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
        End If
        If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
        End If
        If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
        End If
        If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
        End If
        If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
        End If
        If Val(strGrupo(3)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
        Else
            If Val(strGrupo(4)) = 0 Then
                strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
            Else
                strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
            End If
        End If
        If Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
        Else
            strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
        End If
        strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
    End If
    If Left(strFinal, 1) = "u" Then
        ExtensoX = "H" & Mid$(strFinal, 1)
    Else
        ExtensoX = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
    End If

Dim aux As String * 250

    aux = Trim(ExtensoX)
    ExtensoX = Trim(aux)
Sai1:
    Exit Function
Sai:
    Dim NadaV As Long
    NadaV = MsgBox("Ocorreu o erro nº" & Err.Number & Chr(13) & Err.Description & Chr(13) & Chr(13) & "Se o problema persistir, entre em contato com o supervisor!", vbCritical)
    Resume Sai1
End Function

Public Function LPad(s, ByVal C As String, n As Integer) As String
'
' Acrescenta o caracter C à esquerda da string S justificando-a à direita
'
  If Len(C) = 0 Then C = " "
  If n < 1 Then
    LPad = ""
  Else
    LPad = Right$(String$(n, Left$(C, 1)) & s, n)
  End If
End Function
Function DPad(s, n As Integer, Optional C As String = " ") As String
'
' Acrescenta o caracter C à direita da string S para fazer justificação à esquerda
'
    If Len(C) = 0 Then C = " "
    If n < 1 Then
        DPad = ""
    Else
        DPad = Left$(s & String$(n, Left$(C, 1)), n)
    End If
End Function

Function ExtensoHum(nValor As String, Optional Hum As Boolean = True, Optional UmMil As Boolean = True) As String
'----------------------------------------------------------- ----------------------------
' Procedimento : ExtensoHum
' Data/Hora : 05/10/06 22:33
' Autor : OsmarJr
' Propósito : Função de extenso mais completa
' ; nValor - recebe o valor a ser convertido
' ; Hum - indica se o um mil deve ser escrito Hum mil ou Um mil (padrão Hum mil)
' ; UmMil - indica se deve ser escrito Um mil ou Mil (padrão Um mil)
'----------------------------------------------------------- ----------------------------
'
On Error GoTo ExtensoHum_Erro
If IsNull(nValor) Or CCur(nValor) > 999999999.99 Then Exit Function
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String

Dim strUnid(19) As String
    strUnid(1) = "um "
    strUnid(2) = "dois "
    strUnid(3) = "três "
    strUnid(4) = "quatro "
    strUnid(5) = "cinco "
    strUnid(6) = "seis "
    strUnid(7) = "sete "
    strUnid(8) = "oito "
    strUnid(9) = "nove "
    strUnid(10) = "dez "
    strUnid(11) = "onze "
    strUnid(12) = "doze "
    strUnid(13) = "treze "
    strUnid(14) = "quatorze "
    strUnid(15) = "quinze "
    strUnid(16) = "dezesseis "
    strUnid(17) = "dezessete "
    strUnid(18) = "dezoito "
    strUnid(19) = "dezenove "

Dim strDezena(9) As String
    strDezena(1) = "dez "
    strDezena(2) = "vinte "
    strDezena(3) = "trinta "
    strDezena(4) = "quarenta "
    strDezena(5) = "cinqüenta "
    strDezena(6) = "sessenta "
    strDezena(7) = "setenta "
    strDezena(8) = "oitenta "
    strDezena(9) = "noventa "

Dim strCentena(9) As String
    strCentena(1) = "cento "
    strCentena(2) = "duzentos "
    strCentena(3) = "trezentos "
    strCentena(4) = "quatrocentos "
    strCentena(5) = "quinhentos "
    strCentena(6) = "seiscentos "
    strCentena(7) = "setecentos "
    strCentena(8) = "oitocentos "
    strCentena(9) = "novecentos "
    
    strValor = Format$(nValor, "0000000000.00")
    strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
    strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
    strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
    strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo
    For intContador = 1 To 4
        strParte = strGrupo(intContador)
        intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
        If intTamanho = 3 Then
            If Right$(strParte, 2) <> "00" Then
                strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
                intTamanho = 2
            Else
                strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
            End If
        End If
        If intTamanho = 2 Then
            If Val(Right(strParte, 2)) < 20 Then
                strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
            Else
                strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
                If Right$(strParte, 1) <> "0" Then
                    strTexto(intContador) = strTexto(intContador) + "e "
                    intTamanho = 1
                End If
            End If
        End If
        If intTamanho = 1 Then
            strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
        End If
    Next intContador
'Gera o formato final do texto
    If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
    Else
        strFinal = ""
        If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
    End If
    If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
    End If
    If Val(strGrupo(3)) = 0 Then
        strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
    Else
        If Val(strGrupo(4)) = 0 Then
            strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
        Else
            strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
        End If
    End If
    If Val(strGrupo(4)) = 0 Then
        strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
    Else
        strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
    End If
        strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
    End If
    If Hum Then
        If Left(strFinal, 7) = "um mil," Then
            strFinal = "H" & strFinal
        End If
    End If
    If Hum And Not UmMil Then
        If Left(strFinal, = "hum mil," Then
            strFinal = "Mil e " & Right(strFinal, Len(strFinal) -
       End If
    End If
    If Not Hum And Not UmMil Then
        If Left(strFinal, 7) = "um mil," Then
            strFinal = "Mil e " & Right(strFinal, Len(strFinal) - 7)
        End If
    End If

    ExtensoHum = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
    ExtensoHum = Trim(ExtensoHum)

Saida:
    Exit Function

ExtensoHum_Erro:
    MsgBox "Erro: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & " no procedimento ExtensoHum", vbExclamation + vbOKOnly, "Erro: " & CStr(Err.Number)
    Resume Saida
End Function

Salve o módulo com.....ExtensoT

Bom dia silvio,

Fico grato pela força.

Vou adaptar e logo retorno, ok.

Um abraço,

Campos.

ok

Silvio, será que ao copiar ficou alguma coisa pra trás,

Está dando erro na linha 19ª de baixo pra cima;


If Hum And Not UmMil Then
If Left(strFinal, = "hum mil," Then
strFinal = "Mil e " & Right(strFinal, Len(strFinal) -
End If

um abraço,


Campos.

Pode ser....aqui funfa 100%

Silvio, Por favor!
pode me passar dentro de algum formulário, zipado, aqui no forum?

Pois, quando copio do quadro que você forneceu, ao colar, permanece todo desconfigurado, e pode ser aí que, ao acertar as linhas de código devo estar cometendo algum erro de organização.

Grato,

Campos.

Boa tarde..

Vai em anexo.

Bom dia Silvio, como vai,

Geralmente responso e encerro o tópico no mesmo dia, mas dessa vez, tive problemas técnicos na máquina, só foi liberada agora de manhã.

Hoje irei retomar os testes que estava fazendo, logo te respondo.

Um abraço,

Campos.

Silvio, boa tarde amigo,

O aquivo enviado em anexo deu certo, muito bom o módulo, viu.

Fico muito grato pela força.

Somente me desculpe pelo tempo de resposta, pois andei tendo problemas de máquina, o que dificultou meus acessos.


Em abraço,

Grato,

Campos.

O fórum agradece o retorno.

Abraços e sucesso a ti.

igualmente, Silvio.

Boa tarde, eu nao consegui ver o arquivo em anexo para fazer download.

tem como anexar novamente?