Jump to content
Sign in to follow this  
N3on

Aplicação para Word que permita escrever números por extenso?

Recommended Posts

N3on

Boas pessoal,

alguém sabe de uma aplicação para Word que permita escrever números por extenso?

Share this post


Link to post
Share on other sites
jmaocubo

Verifica este que encontrei. atenção que a fónica dos n.º Portugueses é muito mais complexa que a dos Ingleses ;)

Sub NumberToWords()
Dim Number As Long
Dim Words As String
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
If IsNumeric(Selection) Then
    Number = CInt(Selection)
    Select Case Number
    Case 0
        Words = "Zero"
    Case 1 To 999999
        Words = SetThousands(Number)
    Case Else
        MsgBox "Number too large!", vbExclamation, "NumberToWords Macro"
    End Select
Else
    MsgBox "No number to left of insertion point!", _
    vbExclamation, "NumberToWords Macro"
End If
Selection = Words
End Sub

Private Function SetOnes(ByVal Number As Integer) As String
Dim OnesArray(9) As String
    OnesArray(1) = "One"
    OnesArray(2) = "Two"
    OnesArray(3) = "Three"
    OnesArray(4) = "Four"
    OnesArray(5) = "Five"
    OnesArray(6) = "Six"
    OnesArray(7) = "Seven"
    OnesArray(8) = "Eight"
    OnesArray(9) = "Nine"
    SetOnes = OnesArray(Number)
End Function

Private Function SetTens(ByVal Number As Integer) As String
Dim TensArray(9) As String
    TensArray(1) = "Ten"
    TensArray(2) = "Twenty"
    TensArray(3) = "Thirty"
    TensArray(4) = "Fourty"
    TensArray(5) = "Fifty"
    TensArray(6) = "Sixty"
    TensArray(7) = "Seventy"
    TensArray(8) = "Eighty"
    TensArray(9) = "Ninety"
Dim TeensArray(9) As String
    TeensArray(1) = "Eleven"
    TeensArray(2) = "Twelve"
    TeensArray(3) = "Thirteen"
    TeensArray(4) = "Fourteen"
    TeensArray(5) = "Fifteen"
    TeensArray(6) = "Sixteen"
    TeensArray(7) = "Seventeen"
    TeensArray(8) = "Eighteen"
    TeensArray(9) = "Nineteen"
Dim tmpInt1 As Integer
Dim tmpInt2 As Integer
Dim tmpString As String
    tmpInt1 = Int(Number / 10)
    tmpInt2 = Number Mod 10
    tmpString = TensArray(tmpInt1)
    If (tmpInt1 = 1 And tmpInt2 > 0) Then
        tmpString = TeensArray(tmpInt2)
    Else
        If (tmpInt1 > 1 And tmpInt2 > 0) Then
            tmpString = tmpString + " " + SetOnes(tmpInt2)
        End If
    End If
    SetTens = tmpString
End Function

Private Function SetHundreds(ByVal Number As Integer) As String
Dim tmpInt1 As Integer
Dim tmpInt2 As Integer
Dim tmpString As String
    tmpInt1 = Int(Number / 100)
    tmpInt2 = Number Mod 100
    If tmpInt1 > 0 Then tmpString = SetOnes(tmpInt1) + " Hundred"
    If tmpInt2 > 0 Then
        If tmpString > "" Then tmpString = tmpString + " "
        If tmpInt2 < 10 Then tmpString = tmpString + SetOnes(tmpInt2)
        If tmpInt2 > 9 Then tmpString = tmpString + SetTens(tmpInt2)
    End If
    SetHundreds = tmpString
End Function

Private Function SetThousands(ByVal Number As Long) As String
Dim tmpInt1 As Integer
Dim tmpInt2 As Integer
Dim tmpString As String
    tmpInt1 = Int(Number / 1000)
    tmpInt2 = Number - (tmpInt1 * 1000)
    If tmpInt1 > 0 Then tmpString = SetHundreds(tmpInt1) + " Thousand"
    If tmpInt2 > 0 Then
        If tmpString > "" Then tmpString = tmpString + " "
        tmpString = tmpString + SetHundreds(tmpInt2)
    End If
    SetThousands = tmpString
End Function

Fonte: http://word.tips.net/Pages/T000113_Numbers_to_Words.html

Share this post


Link to post
Share on other sites
N3on

É isso que preciso, mas o problema é que trabalho com valores monetários, e este código não aceita valores para lá da virgula...

Share this post


Link to post
Share on other sites
FreiNando

Eu criei uma funções para o Excel à uns anos atrás. Acho que dá para usar no Word.

Em Euros vai até ao centimo, sendo o resto ignorado.

Public Function ExtensoInteiro(Valor) As String
    Dim A As Long, C As Long, D As Long, M As Long, n As Long, o As Long
    Dim MM, MU, NU, ND, NC, S As String, X As String, cA As Integer
    
    MM = Array("", "mil ", "milhões ", "mil milhões ", "biliões ", "mil biliões ", "triliões ", "zzz ", "zzz ")
    MU = Array("", "milhar ", "milhão ", "milhar de milhões ", "bilião ", "milhar biliões ", "triliões ", "zzz ", "zzz ")
    NU = Array("", "um ", "dois ", "três ", "quatro ", "cinco ", "seis ", "sete ", "oito ", "nove ", "dez ", "onze ", "doze ", "treze ", "quatorze ", "quinze ", "dezasseis ", "dezassete ", "dezoito ", "dezanove ")
    ND = Array("", "dez ", "vinte ", "trinta ", "quarenta ", "cinquenta ", "sessenta ", "setenta ", "oitenta ", "noventa ")
    NC = Array("", "cento ", "duzentos ", "trezentos ", "quatrocentos ", "quinhentos ", "seiscentos ", "setecentos ", "oitocentos ", "novecentos ")
    
    If Valor = 0 Then ExtensoInteiro = "Zero": Exit Function
    
    
    'Separar por milhares  -  3 digitos de cada vez
    A = Abs(Int(Valor)) 'Valor inteiro Absoluto
    M = 0 '  numero de Grupos de 3 digitos
    Do
        ' retirar 3 digitos ao valor
        n = Int(A / 1000)
        C = A - n * 1000 'Centena
        A = n ' valor restante
        
        'Titulo dos 3 digitos  -  separador de milhares
        If X <> "" And cA > 0 And cA < 100 Then
            X = "e " & X
        End If
        If C = 1 Then ' Para uma unidade
            X = MU(M) + X
        ElseIf C > 1 Then ' para mais unidades
            X = MM(M) + X
        End If
        
        'Desmembrar a centena
        D = Int(C / 100)
        n = C - D * 100
        If D = 1 And n = 0 Then
            S = "cem "
        Else
            S = NC(D) 'Centenas
        End If
        If D > 0 And n > 0 Then S = S + "e "
        If n > 19 Then
            o = Int(n / 10)
            n = n - 10 * o
            S = S + ND(o)
        Else
            o = 0
        End If
        If o > 1 And n > 1 Then S = S + "e "
        S = S + NU(C)
        
        X = S & X
        
        M = M + 1
        cA = C
    Loop Until A < 1
    If Valor < 0 Then X = "Menos " & X ' Valor negativo
    X = StrConv(Left(X, 1), vbUpperCase) + Right(X, Len(X) - 1)
    ExtensoInteiro = X
End Function

Public Function ExtensoEuros(Valor) As String
    Dim n As Single, D As Integer, M As Long, P As Currency, MM, MU, A As Currency, X As String
    
    MM = Array("", "mil ", "milhões ", "mil milhões ", "biliões ", "mil biliões ", "triliões ", "zzz ", "zzz ")
    MU = Array("", "milhar ", "milhão ", "milhar de milhões ", "bilião ", "milhar biliões ", "triliões ", "zzz ", "zzz ")
    
    If Valor = 0 Then ExtensoEuros = "Zero euros": Exit Function
    
    M = Abs(Int(Valor)) 'euros
    D = 100 * (Valor - M) 'centimos
    A = 0
    Do
        n = Int(M / 1000)
        P = M - n * 1000
        M = n
        If P = 1 Then
            X = MU(A) + X
        ElseIf P > 1 Then
            X = MM(A) + X
        End If
        X = Centena(P) & X
        A = A + 1
    Loop Until n < 1
    X = StrConv(Left(X, 1), vbUpperCase) + Right(X, Len(X) - 1)
    If Abs(Valor) < 2 Then
        X = X & "euro "
    Else
        X = X & "euros "
    End If
    If D = 1 Then X = X + " e um centimo"
    If D > 1 Then X = X + " e " + Centena(D) + " centimos"
    ExtensoEuros = X
End Function

Private Function Centena(Valor) As String
    Dim NU, ND, NC, S As String, M As Integer, n As Integer, o As Integer
    If Valor > 999 Then
        n = Valor - 1000 * Int(Valor / 1000)
    Else
        n = Valor
    End If
    NU = Array("", "um ", "dois ", "três ", "quatro ", "cinco ", "seis ", "sete ", "oito ", "nove ", "dez ", "onze ", "doze ", "treze ", "quatorze ", "quinze ", "dezasseis ", "dezassete ", "dezoito ", "dezanove ")
    ND = Array("", "dez ", "vinte ", "trinta ", "quarenta ", "cinquenta ", "sessenta ", "setenta ", "oitenta ", "noventa ")
    NC = Array("", "cento ", "duzentos ", "trezentos ", "quatrocentos ", "quinhentos ", "seiscentos ", "setecentos ", "oitocentos ", "novecentos ")
    M = Int(n / 100)
    n = n - M * 100
    If M = 1 And n = 0 Then
        S = "cem "
    Else
        S = NC(M)
    End If
    If M > 0 And n > 0 Then S = S + "e "
    If n >= 20 Then
        o = Int(n / 10) 'dezena
        n = n - 10 * o 'unidades
    Else
        
    End If
    S = S + ND(o)
    If o > 1 And n > 1 Then S = S + "e "
    S = S + NU(n)
    Centena = S
End Function


O caminho mais curto para conseguir fazer muitas coisas é fazer uma de cada vez. Samuel Smiles

Share this post


Link to post
Share on other sites
N3on

Excelente, no Excel funciona que é um espectáculo, não consigo é fazer funcionar no word, não me aparece como macro...

Share this post


Link to post
Share on other sites
FreiNando

Para funcionar no Word tens de fazer um Sub tipo:

Public Sub EurosEmExtenso()
    Dim Num As Double
   
    If IsNumeric(Selection) Then
        Num = Val(Selection)
        Selection = Format(Num, "# ##0.00€") & " (" & ExtensoEuros(Num) & ") "
    Else
        MsgBox "Não é número"
    End If
End Sub

Seleciona o numero que queres por em extenso e executas a macro 'EurosEmExtenso'.


O caminho mais curto para conseguir fazer muitas coisas é fazer uma de cada vez. Samuel Smiles

Share this post


Link to post
Share on other sites
N3on

Ok, já percebi, e há maneira para ao fazer o sub, só mandá lo correr a função original? com os centimos e bastando estar ao lado do n+umero e ele escrever por extenso?

Share this post


Link to post
Share on other sites
FreiNando

Já está na resposta do jmaocubo.

A instrução para selecionar a 'palavra' antes do cursor é:

Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend

Para inserir texto no fim do que está selecionado:

Selection.InsertAfter 'Texto'

Para colocar o cursor no fim do texto selecionado afim de continuar a escrever:

Selection.Start = Selection.End

Tudo junto ficaria:

Public Sub EurosEmExtenso()
    Dim Num As Double
    
    Selection.MoveLeft wdWord, 1, wdExtend
    If IsNumeric(Selection) Then
        Num = Val(Selection)
        Selection.InsertAfter " " & ExtensoEuros(Num)
        Selection.Start = Selection.End
    Else
        MsgBox "Não é número"
    End If
End Sub

Para saber o que cada instrução faz, seleciona a instrução no editor de código e pressiona F1.

A ajuda do Word é imprescindivel!


O caminho mais curto para conseguir fazer muitas coisas é fazer uma de cada vez. Samuel Smiles

Share this post


Link to post
Share on other sites
N3on

Peço desculpa estar ainda a xatear, é a primeira vez que uso macros no word... a macro funciona, mas para números certos mas não lê a parte dos centimos, ele corre a função ExtensoEuros mas não a parte dos cêntimos, enquanto no excel fica completo. Já tive a alterar algumas coisas mas não faz os cêntimos.

Share this post


Link to post
Share on other sites
FreiNando

O separador decimal foi escrito usando o ponto do teclado numerico?

Qual o formato que estás usando nas definições regionais?

A instrução Val() aceita ponto(.) para separador decimal.

Troca por CDbl() ou CCur() para estar de acordo com as definições regionais.


O caminho mais curto para conseguir fazer muitas coisas é fazer uma de cada vez. Samuel Smiles

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.