N3on 0 Posted February 8, 2011 Report Share Posted February 8, 2011 Boas pessoal, alguém sabe de uma aplicação para Word que permita escrever números por extenso? Link to post Share on other sites
jmaocubo 0 Posted February 9, 2011 Report Share Posted February 9, 2011 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 Link to post Share on other sites
N3on 0 Posted February 10, 2011 Author Report Share Posted February 10, 2011 É isso que preciso, mas o problema é que trabalho com valores monetários, e este código não aceita valores para lá da virgula... Link to post Share on other sites
FreiNando 22 Posted February 10, 2011 Report Share Posted February 10, 2011 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 Link to post Share on other sites
N3on 0 Posted February 10, 2011 Author Report Share Posted February 10, 2011 Excelente, no Excel funciona que é um espectáculo, não consigo é fazer funcionar no word, não me aparece como macro... Link to post Share on other sites
FreiNando 22 Posted February 10, 2011 Report Share Posted February 10, 2011 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 Link to post Share on other sites
N3on 0 Posted February 11, 2011 Author Report Share Posted February 11, 2011 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? Link to post Share on other sites
FreiNando 22 Posted February 11, 2011 Report Share Posted February 11, 2011 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 Link to post Share on other sites
N3on 0 Posted February 11, 2011 Author Report Share Posted February 11, 2011 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. Link to post Share on other sites
FreiNando 22 Posted February 11, 2011 Report Share Posted February 11, 2011 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 Link to post Share on other sites
RenataFVN 0 Posted November 27, 2020 Report Share Posted November 27, 2020 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? Link to post Share on other sites
Recommended Posts
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 accountSign in
Already have an account? Sign in here.
Sign In Now