Valor Extenso no Word

[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,     

[thoga31]

Mas colocar o valor de modo automático?

[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

[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

[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!!!

[YoungCoder]

exemplo http://uploading.com/files/159m67d6/MACRO.doc/

[acao]

boas

passa aqui que tens um exemplo que funciona.

http://www.portugal-a-programar.pt/index.php?showtopic=50301

cumps

acao

[JOSESOUSA]

Obrigado pela ajuda.

A indicação de "acao" foi muito util, contudo gastaria de poder aceder ao Link - http://www.mediafire.com/?5cebkn5jc3og2eo - , mas este não está a funcionar.

Haverá alternativa???

JS

[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

[acao]

Obrigado pela ajuda.

A indicação de "acao" foi muito util, contudo gastaria de poder aceder ao Link - http://www.mediafire.com/?5cebkn5jc3og2eo - , mas este não está a funcionar.

Haverá alternativa???

JS

link activado

cumps

acao