Prezados Amigos,

 

Gostaria de saber quem possuim uma rotina que escreva valores por extenso (simples) e uma rotina que preencha cheques em impressora LX 300.

EX: R$ 50,00 (cinquenta reais)

 

Fico muito grato.

 

Atenciosamente,

 

Flavio

 

Extenso de barbadão pra ti

tenho um que faz separação silábica também

derrepente poderia vender pra ti ... é que to precisando de grana e talz...

poderia também fazer esse aí do preenchimento do cheque...

só combinarmos e talz...

 

Public Function Extenso(nValor As String) As String

    'Valida Argumento
    If IsNull(nValor) Or nValor <= 0 Or nValor > 9999999999.99 Then Exit Function
   
    'Declaracao de Variaveis
    Dim nContador, nTamanho As Integer
    Dim cValor, cParte, cFinal As String
    ReDim aGrupo(4), aTexto(4) As String
   
    'Matrizes de extensos
    'Array das Unidades
    ReDim aUnid(19) As String
    aUnid(1) = "um ": aUnid(2) = "dois ": aUnid(3) = "três "
    aUnid(4) = "quatro ": aUnid(5) = "cinco ": aUnid(6) = "seis "
    aUnid(7) = "sete ": aUnid(8) = "oito ": aUnid(9) = "nove "
    aUnid(10) = "dez ": aUnid(11) = "onze ": aUnid(12) = "doze "
    aUnid(13) = "treze ": aUnid(14) = "quatorze ": aUnid(15) = "quinze "
    aUnid(16) = "dezesseis ": aUnid(17) = "dezessete ": aUnid(18) = "dezoito "
    aUnid(19) = "dezenove "
   
    'Array das dezenas
    ReDim aDezena(9) As String
    aDezena(1) = "dez ": aDezena(2) = "vinte ": aDezena(3) = "trinta "
    aDezena(4) = "quarenta ": aDezena(5) = "cinquenta "
    aDezena(6) = "sessenta ": aDezena(7) = "setenta ": aDezena(8) = "oitenta "
    aDezena(9) = "noventa "
   
    'Array das Centenas
    ReDim aCentena(9) As String
    aCentena(1) = "cento ": aCentena(2) = "duzentos "
    aCentena(3) = "trezentos ": aCentena(4) = "quatrocentos "
    aCentena(5) = "quinhentos ": aCentena(6) = "seiscentos "
    aCentena(7) = "setecentos ": aCentena(8) = "oitocentos "
    aCentena(9) = "novecentos "
   
    'Separa valor em grupos (milhao(1), mil(2),unidades de milhar(3),
    cValor = Format$(nValor, "0000000000.00")
    aGrupo(1) = Mid$(cValor, 2, 3)
    aGrupo(2) = Mid$(cValor, 5, 3)
    aGrupo(3) = Mid$(cValor, 8, 3)
    aGrupo(4) = "0" + Mid$(cValor, 12, 2)
   
    'Calcula cada grupo
    For nContador = 1 To 4
        cParte = aGrupo(nContador)
        nTamanho = Switch(Val(cParte) < 10, 1, Val(cParte) < 100, 2, Val(cParte) < 1000, 3)
        If nTamanho = 3 Then
            If Right$(cParte, 2) <> "00" Then
                aTexto(nContador) = aTexto(nContador) + aCentena(Left(cParte, 1)) + "e "
                nTamanho = 2
            Else
                aTexto(nContador) = aTexto(nContador) + IIf(Left$(cParte, 1) = "1", "cem ", aCentena(Left(cParte, 1)))
            End If
        End If
        If nTamanho = 2 Then
            If Val(Right(cParte, 2)) < 20 Then
                aTexto(nContador) = aTexto(nContador) + aUnid(Right(cParte, 2))
            Else
                aTexto(nContador) = aTexto(nContador) + aDezena(Mid(cParte, 2, 1))
                If Right$(cParte, 1) <> "0" Then
                    aTexto(nContador) = aTexto(nContador) + "e "
                    nTamanho = 1
                End If
            End If
        End If
        If nTamanho = 1 Then
            aTexto(nContador) = aTexto(nContador) + aUnid(Right(cParte, 1))
        End If
    Next
   
   
    If Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) = 0 And Val(aGrupo(4)) <> 0 Then
        cFinal = aTexto(4) + IIf(Val(aGrupo(4)) = 1, "centavo", "centavos")
    Else
        cFinal = ""
        cFinal = cFinal + IIf(Val(aGrupo(1)) <> 0, aTexto(1) + IIf(Val(aGrupo(1)) > 1, "milhões ", "milhão "), "")
        If Val(aGrupo(2) + aGrupo(3)) = 0 Then
            cFinal = cFinal + "de "
        Else
            '***** morcego ******
            cFinal = cFinal + IIf(Val(aGrupo(2)) <> 0, aTexto(2) + "mil " + "e ", "")
        End If
        cFinal = cFinal + aTexto(3) + IIf(Val(aGrupo(1) + aGrupo(2) + aGrupo(3)) = 1, "real ", "reais ")
        cFinal = cFinal + IIf(Val(aGrupo(4)) <> 0, "e " + aTexto(4) + IIf(Val(aGrupo(4)) = 1, "centavo", "centavos"), "")
    End If
    Extenso = cFinal

End Function

Flavio,

 

Não tô no escritório agora, mas, quando chegar, vou disponibilizar no link TROCA DE ARQUIVOS, ai é só você ir lá e pegar a rotinha pronta do valor por extenso.

 

Prezado Xevious,

Muito obrigado pela ronita, é claro que todos nós precisamos de dinheiro!!!, más, não é o caso, quem sabe se futuramente você precisse de algo que eu possa te ajudar e que não tenha preço!, desde já estou muito grato, estou desenvolvendo um sistema para a empresa que eu trabalho, caso, seja de sua livre e espôntanea vontade queira desenvolver a rotina de preenchimento de cheque, fique inteiramente avontade.

Muito obrigado pela sua atenção.

 

Grato .

 

Flavio

 

Prezado Wellington,

Estou muito grato pela sua atenção, espero também um dia te ajudar!!!

Abraços de um Amigo chamado Flavio.