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

[N3on 0]

Boas pessoal,

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

[jmaocubo 0]

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

[N3on 0]

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

[FreiNando 22]

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

[N3on 0]

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

[FreiNando 22]

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'.

[N3on 0]

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?

[FreiNando 22]

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!

[N3on 0]

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.

[FreiNando 22]

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.

[RenataFVN 0]

Pessoal, preciso de macro que escreva números não monetários por extenso. Na verdade, vou trabalhar com unidade de massa (g). Alguém poderia me ajudar?