USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (Crystal Reports)

Título da Dica:  Crystal 11 - Conversão de valor para Moeda por Extenso
Postada em 1/3/2007 por Marcos         
Atenção: Segue uma dica para quem quer converter um valor para extenso

Vá na area WorkShop formula do crystal e dê um Novo para função Personalizada.
Na sintaxe, altere de Sintaxe do  Crystal  para Sixtase do Basic.
Em seguida no editor de formula adicione o código a seguir

Function Extenso (Valor as Number) as String
    if Valor <= 0 or Valor > 999999999.99 then
        Exit Function
    end if

'Variáveis
Dim vlsValor     as String
Dim vlsParte     as String
Dim vlsFinal     as String

Dim vliContador  as Number
Dim vliTamanho   as Number

'Arrays
Dim alsGrupo()   as String
Redim alsGrupo(4)

Dim alsTexto()   as String
Redim alsTexto(4)

'Matrizes de extensos (Parciais)
Dim mlsUnidade() as String
Redim mlsUnidade(19)

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

Dim mlsDezena() as String
Redim mlsDezena(9)

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

Dim mlsCentena() as String
Redim mlsCentena(9)

mlsCentena(1) = "cento ":
mlsCentena(2) = "duzentos ":
mlsCentena(3) = "trezentos ":
mlsCentena(4) = "quatrozentos ":
mlsCentena(5) = "quinhentos ":
mlsCentena(6) = "seiscentos ":
mlsCentena(7) = "setecentos ":
mlsCentena(8) = "oitocentos ":
mlsCentena(9) = "novecentos ":


'Separa valor em grupos
vlsValor = ToText(Valor, "0000000000.00")
alsGrupo(1) = Mid(vlsValor, 2, 3)
alsGrupo(2) = Mid(vlsValor, 5, 3)
alsGrupo(3) = Mid(vlsValor, 8, 3)
alsGrupo(4) = "0" + Mid(vlsValor, 12,2)


    'Calcula cada Grupo
    For vliContador = 1 to 4
        vlsParte = alsGrupo(vliContador)

        If ToNumber(vlsParte) > 0 then
        
            vliTamanho  = Switch(val(vlsParte) < 10, 1, Val(vlsParte) < 100, 2, Val(vlsParte) < 1000, 3)

            if vliTamanho = 3 then
            
                If Right(vlsParte, 2) <> "00" Then
                    alsTexto(vliContador) = alsTexto(vliContador) + mlsCentena(ToNumber(Left(vlsParte, 1))) + "e "
                    vliTamanho = 2
                Else
                    alsTexto(vliTamanho) = alsTexto(vliContador) + Iif(Left(vlsParte, 1) = "1", "cem ", mlsCentena(ToNumber(Left(vlsParte, 1))))
                End If

            End if


            If vliTamanho = 2 Then
            
                If Val(Right(vlsParte, 2)) < 20 then
                    alsTexto(vliContador) = alsTexto(vliContador) + mlsUnidade(ToNumber(Right(vlsParte, 2)))
                Else
                    alsTexto(vliContador) = alsTexto(vliContador) + mlsDezena(ToNumber(Mid(vlsParte, 2,1)))

                    If Right(vlsParte, 1) <> "0" then
                        alsTexto(vliContador) = alsTexto(vliContador) + "e "
                        vliTamanho = 1
                    End IF

                End If

            End If


            If vliTamanho = 1 Then
                alsTexto(vliContador) = alsTexto(vliContador) + mlsUnidade(ToNumber(Right(vlsParte, 1)))
            End IF
          
        
        End If

    Next

    'Final
    If Val(alsGrupo(1)+ alsGrupo(2) + alsGrupo(3) ) = 0 And Val(alsGrupo(4)) <> 0 Then
        vlsFinal = alsTexto(4) + IIF (Val(alsGrupo(4)) = 1, "centavo", "centavos")
    Else
        vlsFinal = ""
        vlsFinal = vlsfinal + IIF(Val(alsGrupo(1)) <> 0, alsTexto(1) + IIF(Val(alsGrupo(1)) > 1, "milhões  ", "milhão "), "")

       If Val(alsGrupo(2) + alsGrupo(3)) = 0 Then
            vlsFinal = vlsFinal + "de "
       Else
            vlsFinal = vlsFinal + IIF(Val(alsGrupo(2)) <> 0 , alsTexto(2) + "mil ", "")
       End IF
        
        vlsFinal = vlsFinal + alsTexto(3) + IIF(Val(alsGrupo(1) + alsGrupo(2) + alsGrupo(3)) = 1, "real ", "reais ")
        vlsFinal = vlsFinal + IIF(Val(alsGrupo(4)) <> 0, "e " + alsTexto(4) + IIF(Val(alsGrupo(4)) = 1, "centavo", "centavos"), "")
    End if




    Extenso = Ucase(Mid(vlsFinal, 1,1)) + LCase(Mid(vlsFinal, 2))


End Function

Para verificar o resultado, crie um relatório em branco,
e utilize

Extenso({CampoaSerConvertido})
 


CyberWEB Network Ltda.    © Copyright 2000-2022   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página