Jump to content
Sign in to follow this  
JOSESOUSA

Valor Extenso no Word

Recommended Posts

JOSESOUSA

Peço ajuda ao FORUM para esta questão.

Colocar valor por extenso no Word.

Tipo recibo.

Data 28/Fevereiro/2012                                                    Importância:     

Foi feita a despesa a quantia de, (extenso)     

a fim de,     

Share this post


Link to post
Share on other sites
JOSESOUSA

sim de forma automática.

já sei como fazer se o valor estiver encostado à expressão de extenso ex:100 € (cem euros).

O que eu queria era colocar o extenso automatico noutro paragrafo - ex. através de preenchimento de campos de formulario???

Obrigado

Share this post


Link to post
Share on other sites
YoungCoder

Insere o código num modulo.

Este codigo converte o "texto" seleccionado para extenso...

Option explicit

Public gstrSeparadorDecimal As String
Public gstrSeparadorMilhar As String
Public gstrSeparadorData As String

Public Sub ConverteSeleccao()
    Dim sselect As String
    
    gstrSeparadorDecimal = "."
    gstrSeparadorMilhar = ","
    gstrSeparadorData = "/"
    
    sselect = Selection.Range
    Selection.TypeText Text:=Extenso(sselect)
    
End Sub

'*************************************************************
' Função CDUEXTENSO - CALLED BY EXTENSO (BELLOW)
' Retorna um valor por extenso
'*************************************************************
Function CDUExtenso(ByVal Valor As Integer) As String

    Dim eastrU(0 To 19) As String
    Dim eastrD(2 To 9) As String
    Dim eastrC(0 To 9) As String
    Dim estrValor As String
    
    eastrU(0) = ""
    eastrU(1) = " e um"
    eastrU(2) = " e dois"
    eastrU(3) = " e três"
    eastrU(4) = " e quatro"
    eastrU(5) = " e cinco"
    eastrU(6) = " e seis"
    eastrU(7) = " e sete"
    eastrU(8) = " e oito"
    eastrU(9) = " e nove"
    eastrU(10) = " e dez"
    eastrU(11) = " e onze"
    eastrU(12) = " e doze"
    eastrU(13) = " e treze"
    eastrU(14) = " e quatorze"
    eastrU(15) = " e quinze"
    eastrU(16) = " e dezesseis"
    eastrU(17) = " e dezessete"
    eastrU(18) = " e dezoito"
    eastrU(19) = " e dezenove"
    
    eastrD(2) = " e vinte"
    eastrD(3) = " e trinta"
    eastrD(4) = " e quarenta"
    eastrD(5) = " e cinqüenta"
    eastrD(6) = " e sessenta"
    eastrD(7) = " e setenta"
    eastrD(8) = " e oitenta"
    eastrD(9) = " e noventa"
    
    eastrC(0) = ""
    eastrC(1) = ", cento"
    eastrC(2) = ", duzentos"
    eastrC(3) = ", trezentos"
    eastrC(4) = ", quatrocentos"
    eastrC(5) = ", quinhentos"
    eastrC(6) = ", seiscentos"
    eastrC(7) = ", setecentos"
    eastrC(8) = ", oitocentos"
    eastrC(9) = ", novecentos"
    
    Select Case Valor
        Case 100
            CDUExtenso = " e cem"
        Case 0
            CDUExtenso = ""
        Case 1
            CDUExtenso = "um"
        Case Else
            estrValor = Format(Valor, "000")
            CDUExtenso = eastrC(Val(Left(estrValor, 1)))
            
            Select Case Val(Mid(estrValor, 2, 1))
                Case 0, 1
                    CDUExtenso = CDUExtenso & eastrU(Val(Right(estrValor, 2)))
                Case Else
                    CDUExtenso = CDUExtenso & eastrD(Val(Mid(estrValor, 2, 1)))
                    If Val(Right(estrValor, 1)) > 0 Then CDUExtenso = CDUExtenso & eastrU(Val(Right(estrValor, 1)))
            End Select
    End Select

End Function


'*************************************************************
' Função EXTENSO  - MAIN FUNCTION - CALL THIS ONE
' Retorna um valor por extenso
'*************************************************************
Public Function Extenso(ByVal Valor As Double) As String

    Dim eastrInteiro() As String
    Dim eastrMilhares() As String
    Dim i As Integer, j As Integer
    Dim estrTeste As String
    Dim eastrParticula(0 To 2) As String
    
    eastrParticula(0) = ""
    eastrParticula(1) = " mil"
    eastrParticula(2) = " milh"
    
    eastrInteiro = Split(Format(Valor, "###,###,##0.00"), gstrSeparadorDecimal)
    eastrMilhares = Split(eastrInteiro(0), gstrSeparadorMilhar)
    
    estrTeste = ""
    For i = 0 To UBound(eastrMilhares)
        eastrMilhares(i) = CDUExtenso(eastrMilhares(i))
        estrTeste = estrTeste & eastrMilhares(i)
    Next
    eastrInteiro(1) = CDUExtenso(eastrInteiro(1))
    
    If estrTeste & eastrInteiro(1) = "" Then
        Extenso = "zero euros"
    Else
        j = 0
        For i = UBound(eastrMilhares) To 0 Step -1
            If j = 2 Then
                If Trim(eastrMilhares(i)) = "um" Then
                    eastrParticula(j) = eastrParticula(j) & "ão"
                Else
                    eastrParticula(j) = eastrParticula(j) & "ões"
                End If
            End If
            Extenso = eastrMilhares(i) & eastrParticula(j) & Extenso
            j = j + 1
        Next
        If Extenso = "um" Then
            Extenso = Extenso & " euro"
        Else
            Extenso = Extenso & " euros"
        End If
        
        If eastrInteiro(1) <> "" Then
            If eastrInteiro(1) = "um" Then
                Extenso = IIf(Extenso <> "", Extenso & " e um Centimo", "um centimo")
            Else
                Extenso = Extenso & eastrInteiro(1) & " centimos"
            End If
        End If
        
        If Left(Extenso, 2) = " e" Or Left(Extenso, 2) = ", " Then Extenso = Right(Extenso, Len(Extenso) - 2)
        Extenso = Trim(Extenso)
        
    End If

End Function


IIF(strQuestion = "Stupid",doSEARCH!,doHELP!)

Share this post


Link to post
Share on other sites
JOSESOUSA

Já coloquei o Código mas, dá ERRO.

Não tenho muita experiencia em programação.

Preciso de algumas dicas para fazer funcionar o Código.

Atenção - Não sou programador - apenas Utilizador com vontade de aprender mais qualquer coisa!!!

Share this post


Link to post
Share on other sites
JOSESOUSA

Muito Obrigado a todos os que responderam a este assunto.

As informações enviadas foram muito uteis e resolveram na perfeição o meu problema

Apenas dei uns ajustes para o meu caso em particular.

Uma vez mais Obrigado.

JS

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
Sign in to follow this  

×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.