none
Salvar como: pasta e subpasta RRS feed

  • Pergunta

  • Bom dia. Gostaria de saber se existe um meio de salvar automaticamente meus documentos do word em pastas e subpastas específicas.

    Melhor dizendo, quero salvar minhas petições tendo como pasta principal o nome da parte e como subpasta o número do processo. No caso do exeplo abaixo, seria algo como: c:\xxxxx\IRES GAELZER ZAMIN\028.1.14.0000698-4\nome do arquivo.doc

    Sempre salvo meus documentos neste padrão, porém, manualmente. Gostaria que o próprio software copiasse os conteúdo dos campos nome e processo e os utilizasse como pasta/subpasta.

    Obrigado!

    EXEMPLO:

    Processo sob nº 028/1.14.0000698-4

     

     ires gaelzer zamin, por seu representante judicial, já qualificado nos autos em epígrafe, vem, perante Vossa Excelência, dizer e requerer o quanto segue:

    quinta-feira, 20 de outubro de 2016 12:26

Todas as Respostas

  • Dúvida: o nome do documento salvo será sempre "nome do arquivo.doc"?

    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    quinta-feira, 20 de outubro de 2016 17:25
    Moderador
  • o nome do arquivo será sempre o "título" nas propriedades.

    Obrigado

    sexta-feira, 21 de outubro de 2016 18:39
  • Agora você me confundiu. O que quer dizer com "nas propriedades"?

    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    sexta-feira, 21 de outubro de 2016 19:26
    Moderador
  • Quero dizer que o nome do arquivo fica sempre igual ao conteúdo do campo título (campo título das propriedades do documento); por exemplo, se no campo título do documento for "pedido de expedição de alvará", o nome do arquivo será "pedido de expedição de alvará.docx".

    Não consigo colar o print da tela aqui para ilustrar este título e propriedades que falo, mas no word 2010 aparece à direita da tela quando clico em arquivo/informações.

    Espero ter ajudado a compreender...Obrigado mais uma vez.

    segunda-feira, 24 de outubro de 2016 13:54
  • Cole o código a seguir no projeto de Normal do seu Word:

    Option Explicit
    
    Sub SalvarEspecial()
        Const DEFAULT_PATH As String = "c:\temp\"
        
        Dim FileName As String
        Dim FilePath As String
        Dim RegExp As Object 'VBScript_RegExp_55.RegExp
        
        If ActiveDocument Is Nothing Then
            MsgBox "Não há um documento aberto.", vbExclamation
            GoTo Quit
        End If
        
        FileName = ActiveDocument.BuiltInDocumentProperties("Title").Value
        If FileName = "" Then
            MsgBox "Preencha a propriedade 'Título' do documento antes de continuar.", vbExclamation
            GoTo Quit
        End If
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.Global = True
        RegExp.IgnoreCase = True
        RegExp.Pattern = "\d.+"
        FilePath = ActiveDocument.Paragraphs(1).Range.Text
        If RegExp.Test(FilePath) = False Then
            MsgBox "Número de processo não encontrado.", vbExclamation
            GoTo Quit
        End If
        
        FilePath = RegExp.Execute(FilePath)(0)
        RegExp.Pattern = "[ /-]"
        FilePath = RegExp.Replace(FilePath, ".")
        
        RegExp.Pattern = "[^\d\.]"
        FilePath = RegExp.Replace(FilePath, "")
        
        FilePath = DEFAULT_PATH & FilePath
        On Error Resume Next
        MkDir FilePath
        On Error GoTo 0
        FilePath = FilePath & "\"
        
        ActiveDocument.SaveAs2 FilePath & FileName, wdFormatXMLDocument
    Quit:
    End Sub
    

    Quando quiser salvar o documento dessa forma, não clique em Salvar, mas sim execute essa macro.

    Sugiro que você acrescente um atalho a essa macro na barra de ferramentas de acesso rápido, como mostrado aqui: http://ambienteoffice.com.br/blog/subprocedimentos/#barra-de-ferramentas-de-acesso-rapido


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 24 de outubro de 2016 15:44
    Moderador
  • Ao executar esta macro recebo a seguinte mensagem:

    "erro em tempo de execução '5152' O nome do documento não é válido.

    segunda-feira, 24 de outubro de 2016 17:20
  • Em qual linha obteve erro? Você depurou o código?

    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 24 de outubro de 2016 18:23
    Moderador
  • Depurei sim, o erro está na penúltima linha:

        ActiveDocument.SaveAs2 FilePath & FileName, wdFormatXMLDocument

    segunda-feira, 24 de outubro de 2016 19:14
  • Esqueci de avisar. Você mudou o diretório abaixo:

    Const DEFAULT_PATH As String = "c:\temp\"
    

    Para um diretório que existe no seu computador? Não esqueça de terminar o caminho com \


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 24 de outubro de 2016 19:45
    Moderador
  • Ainda assim não funcionou. Há outra macro gravada no Normal, poderia ser por isso? Essa outra macro serve para escrever valores por extenso. Teria como lhe enviar o documento para você entender melhor o que acontece?

    Assim que aparece para mim (as 2 macros):

    Sub WValorExtenso()
    
    '    Selection.MoveLeft unit:=wdWord, Count:=1, Extend:=wdExtend
        
        On Error GoTo Erro
        
        Selection.MoveStartUntil cset:=" ", Count:=wdBackward
        Selection.TypeText FormatCurrency(Selection.Text, 2) & " (" & ConverterParaExtenso(Selection.Text) & ")"
        
        GoTo Pula
        
    Erro:
    
        MsgBox "O valor deve ser informado sem ponto e sem 'R$'." & Chr$(10) & "O cursor deve estar imediatamente após o valor." _
        & Chr$(10) & "O valor não pode estar em início de parágrafo." & Chr$(10) & _
        "Exemplo: 1250,35", vbCritical, "Dados inválidos!"
        
        Exit Sub
                
    Pula:
        
    End Sub
    
    Public Function ConverterParaExtenso(NumeroParaConverter As String) As String
    Dim sExtensoFinal As String, sExtensoAtual As String
    Dim i As Integer
    Dim iQtdGrupos As Integer
    Dim sDecimais As String
    Dim sMoedaSing As String, sMoedaPlu As String, sCentavos As String, sConector As String
    Dim bSufMoeda As Boolean
    Dim vArrCenten As Variant
    
    'Separa os Decimais
    If InStr(1, NumeroParaConverter, ",") > 0 Then
    sDecimais = Right(NumeroParaConverter, Len(NumeroParaConverter) - InStr(1, NumeroParaConverter, ","))
    NumeroParaConverter = Mid(NumeroParaConverter, 1, InStr(1, NumeroParaConverter, ",") - 1)
    End If
    
    'Obtém a separação de milhares
    iQtdGrupos = Fix(Len(NumeroParaConverter) / 3)
    If Len(NumeroParaConverter) Mod 3 > 0 Then
    iQtdGrupos = iQtdGrupos + 1
    End If
    
    'Chama as funções para escrever o número
    If iQtdGrupos > 2 Then bSufMoeda = True
    
    For i = iQtdGrupos To 1 Step -1
    sExtensoAtual = DesmembraValor(NumeroParaConverter, i)
    If i = 1 Then
    If sExtensoAtual = "" Then
    sExtensoFinal = sExtensoFinal & sExtensoAtual
    Else
    If sExtensoFinal = "" Then
    sExtensoFinal = sExtensoFinal & sExtensoAtual
    Else
    
    vArrCenten = Array("cem", "duzentos", "trezentos", "quatrocentos", _
    "quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos")
    
    sConector = ""
    
    For w = 0 To 8
    If Len(NumeroParaConverter) >= 4 And Right(NumeroParaConverter, 2) = "00" _
    And sExtensoAtual <> vArrCenten(w) Then sConector = "e "
    Exit For
    Next w
    
    If Len(NumeroParaConverter) >= 4 And Left(Right(NumeroParaConverter, 3), 1) = "0" Then sConector = " e "
    
    If Len(NumeroParaConverter) >= 4 And sExtensoAtual = "cem" Then sConector = " e "
    
    sExtensoFinal = sExtensoFinal & sConector & sExtensoAtual
    End If
    End If
    Else
    sExtensoFinal = sExtensoFinal & sExtensoAtual
    End If
    
    If iQtdGrupos > 2 Then
    Select Case i
    Case 1, 2
    If sExtensoAtual <> "" Then
    bSufMoeda = False
    End If
    End Select
    End If
    Next i
    
    'Define a moeda
    sMoedaPlu = " reais"
    sMoedaSing = " real"
    
    If bSufMoeda = True Then sMoedaPlu = " de reais"
    
    'Escreve os Centavos
    sCentavos = EscreveCentavos(sDecimais)
    
    'Adiciona a moeda e os centavos
    sExtensoFinal = IIf((sExtensoFinal = ""), "", sExtensoFinal & IIf((sExtensoFinal = "um"), sMoedaSing, sMoedaPlu)) _
    & IIf((sExtensoFinal = ""), sCentavos, IIf((sCentavos = ""), "", " e " & sCentavos))
    
    'retorna o resultado
    
    sExtensoFinal = Replace(sExtensoFinal, "  ", " ", 1, , vbTextCompare)
    
    ConverterParaExtenso = Replace(sExtensoFinal, "e e ", "e ", 1, , vbTextCompare)
    
    End Function
    
    Private Function DesmembraValor(sValor As String, iGrupoDiv As Integer) As String
    Dim iValor As Integer
    Dim sExtenso As String
    Dim iDivResto As Integer
    Dim iDivInteiro As Integer
    Dim iPosInicMid As Integer
    Dim iTamMid As Integer
    Dim sComplemento As String
    Dim vArrDez1 As Variant
    Dim vArrDez2 As Variant
    Dim vArrCentena As Variant
    
    vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _
    "dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _
    "dezoito", "dezenove")
    
    vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _
    "setenta", "oitenta", "noventa")
    
    vArrCentena = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _
    "quinhentos", "seiscentos", "setecentos", "oitocentos", "novecentos")
    
    'Pega o Valor a ser escrito e desmembra para o grupo numérico correto
    iPosInicMid = Len(sValor) - ((3 * iGrupoDiv) - 1)
    If iPosInicMid <= 1 Then
    iTamMid = 2 + iPosInicMid
    Else
    iTamMid = 3
    End If
    
    If iPosInicMid < 1 Then iPosInicMid = 1
    
    iValor = CInt(Mid(sValor, iPosInicMid, iTamMid))
    
    Select Case iGrupoDiv
    Case 2
    sComplemento = " mil "
    Case 3
    If iValor = 1 Then
    sComplemento = " milhão "
    Else
    sComplemento = " milhões "
    End If
    Case 4
    If iValor = 1 Then
    sComplemento = " bilhão "
    Else
    sComplemento = " bilhões "
    End If
    Case 5
    If iValor = 1 Then
    sComplemento = " trilhão "
    Else
    sComplemento = " trilhões "
    End If
    End Select
    
    Select Case iValor
    Case 0 To 19
    sExtenso = vArrDez1(iValor)
    Case 20 To 99
    iDivInteiro = Fix(iValor / 10)
    iDivResto = iValor Mod 10
    
    If iDivResto = 0 Then
    sExtenso = vArrDez2(iDivInteiro - 2)
    Else
    sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto)
    End If
    Case 100 To 999
    iDivInteiro = Fix(iValor / 100)
    iDivResto = iValor Mod 100
    
    If iDivResto = 0 Then
    If iDivInteiro = 1 Then
    sExtenso = vArrCentena(0)   'Cem
    Else
    sExtenso = vArrCentena(iDivInteiro) 'inteiro maior que 100
    End If
    Else
    sExtenso = vArrCentena(iDivInteiro) & " e "
    Select Case iDivResto
    Case 0 To 19
    sExtenso = sExtenso & vArrDez1(iDivResto)
    Case 20 To 99
    iDivInteiro2 = Fix(iDivResto / 10)
    iDivResto2 = iDivResto Mod 10
    
    If iDivResto2 = 0 Then
    sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2)
    Else
    sExtenso = sExtenso & vArrDez2(iDivInteiro2 - 2) & " e " & vArrDez1(iDivResto2)
    End If
    End Select
    End If
    
    End Select
    
    If sExtenso = "um" And sComplemento = " mil " And Len(sValor) < 7 Then
    sComplemento = "mil "
    sExtenso = ""
    End If
    
    smilx = Right(sValor, 6)
    
    If sComplemento = " milhão " Then
    If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhão e " Else sComplemento = " milhão "
    End If
    
    If sComplemento = " milhões " Then
    If Right(smilx, 6) = "000000" Then
    sComplemento = " milhões "
    Else
    If Left(smilx, 2) = "00" And Right(smilx, 5) <> "00000" Then sComplemento = " milhões e " Else sComplemento = " milhões "
    End If
    End If
    
    DesmembraValor = sExtenso & IIf(iValor > 0, sComplemento, "")
    
    End Function
    
    Private Function EscreveCentavos(sCent As String) As String
    Dim sExtenso As String
    Dim iDivResto As Integer
    Dim iDivInteiro As Integer
    Dim sComplemento As String
    Dim vArrDez1 As Variant
    Dim vArrDez2 As Variant
    Dim iCent As Integer
    
    vArrDez1 = Array("", "um", "dois", "três", "quatro", "cinco", "seis", "sete", "oito", "nove", _
    "dez", "onze", "doze", "treze", "quatorze", "quinze", "dezesseis", "dezessete", _
    "dezoito", "dezenove")
    
    vArrDez2 = Array("vinte", "trinta", "quarenta", "cinquenta", "sessenta", _
    "setenta", "oitenta", "noventa")
    
    'Adequando para duas casas decimais
    iCent = Fix(sCent & String(2 - Len(sCent), "0"))
    
    'Escrevendo Singular ou plural
    If iCent = 1 Then
    sComplemento = " centavo"
    Else
    sComplemento = " centavos"
    End If
    
    'Calculando os valores
    Select Case iCent
    Case 0 To 19
    sExtenso = vArrDez1(iCent)
    Case 20 To 99
    iDivInteiro = Fix(iCent / 10)
    iDivResto = iCent Mod 10
    
    If iDivResto = 0 Then
    sExtenso = vArrDez2(iDivInteiro - 2)
    Else
    sExtenso = vArrDez2(iDivInteiro - 2) & " e " & vArrDez1(iDivResto)
    End If
    End Select
    
    EscreveCentavos = IIf(iCent > 0, sExtenso & sComplemento, "")
    
    End Function
    
    Option Explicit
    
    Sub SalvarEspecial()
        Const DEFAULT_PATH As String = "c:\temp\"
        
        Dim FileName As String
        Dim FilePath As String
        Dim RegExp As Object 'VBScript_RegExp_55.RegExp
        
        If ActiveDocument Is Nothing Then
            MsgBox "Não há um documento aberto.", vbExclamation
            GoTo Quit
        End If
        
        FileName = ActiveDocument.BuiltInDocumentProperties("Title").Value
        If FileName = "" Then
            MsgBox "Preencha a propriedade 'Título' do documento antes de continuar.", vbExclamation
            GoTo Quit
        End If
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.Global = True
        RegExp.IgnoreCase = True
        RegExp.Pattern = "\d.+"
        FilePath = ActiveDocument.Paragraphs(1).Range.Text
        If RegExp.Test(FilePath) = False Then
            MsgBox "Número de processo não encontrado.", vbExclamation
            GoTo Quit
        End If
        
        FilePath = RegExp.Execute(FilePath)(0)
        RegExp.Pattern = "[ /-]"
        FilePath = RegExp.Replace(FilePath, ".")
        
        RegExp.Pattern = "[^\d\.]"
        FilePath = RegExp.Replace(FilePath, "")
        
        FilePath = DEFAULT_PATH & FilePath
        On Error Resume Next
        MkDir FilePath
        On Error GoTo 0
        FilePath = FilePath & "\"
        
        ActiveDocument.SaveAs2 FilePath & FileName, wdFormatXMLDocument
    Quit:
    End Sub
    



    terça-feira, 25 de outubro de 2016 19:30
  • Remova a instrução Option Explicit e tente novamente.

    ---

    Verifique se seu código está compilando.


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    quarta-feira, 26 de outubro de 2016 09:45
    Moderador
  • Removi a instrução Option Explicit e a primeira macro (valor por extenso) voltou a funcionar.

    Porém, a SalvarEspecial continua dando o mesmo erro.

    Eu não alterei o caminho na macro ainda, mas criei a pasta c:\temp\

    Percebi que estão sendo criadas subpastas na temp, só que não é o nome da parte (do documento) como era para ser, mas sim um número. Por exemplo, qndo executo a macro cria a pasta 01. Ao executar pela segunda vez cria a pasta 02, e assim por diante.

    Estas subpastas estão vazias.

    quarta-feira, 26 de outubro de 2016 13:49
  • Usei como exemplo o cabeçalho que você postou no início do tópico:

    Processo sob nº 028/1.14.0000698-4

    IRES GAELZER ZAMIN, por seu representante judicial, já qualificado nos autos em epígrafe, vem, perante Vossa Excelência, dizer e requerer o quanto segue:

    O número do processo deve estar na primeira linha do parágrafo.

    Crie pontos de interrupção (F9) pelo código e verifique qual valor FilePath está assumindo.



    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    quarta-feira, 26 de outubro de 2016 14:08
    Moderador
  • Desculpe, o exemplo que citei no início do tópico não está completo, pois não sabia que teria influencia no código.

    Antes do nº do processo existe mais um parágrafo, conforme o seguinte padrão:

    EXCELENTÍSSIMO(A) SENHOR(A) DOUTOR(A) JUIZ(A) DE DIREITO DA 3ª VARA cível DA COMARCA DE santa rosa/RS

    Processo sob nº 028/1.12.0008274-1



     

    querino zamin,já qualificado nos autos em epígrafe, vem, por meio dos seus advogados, perante Vossa Excelência, dizer e requerer o quanto segue:

    O que pode mudar entre uma petição e outra é o número de linha em branco entre cada paragrafo, não sei se isso influencia no código...


    quinta-feira, 27 de outubro de 2016 19:34
  • Mude a linha abaixo do códibo:

        FilePath = ActiveDocument.Paragraphs(1).Range.Text

    para:

        FilePath = ActiveDocument.Paragraphs(2).Range.Text

    O número dentro do parênteses corresponde ao parágrafo do documento.


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    sexta-feira, 28 de outubro de 2016 00:00
    Moderador
  • OK, agora está salvando na pasta "temp", porém, está criando somente a subpasta do nº do processo, mas não do nome da parte. A ideia era que criasse a pasta no padrão: C:\.......\nome da parte\nº do processo\nome do arquivo

    De qualquer forma, agradeço a atenção dispensada até aqui!

    sexta-feira, 28 de outubro de 2016 19:24
  • "mas não do nome da parte"

    Verdade, esqueci desse requisito.

    Em qual parágrafo ficará o nome do cliente? 3?


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    sábado, 29 de outubro de 2016 13:12
    Moderador
  • sim, 3º parágrafo (sem contar linhas em branco).

    O nome da parte já está formatado como campo (Fillin) nos meus modelos, caso isso faça alguma diferença pro código...


    segunda-feira, 7 de novembro de 2016 17:25
  • Option Explicit
    
    Sub SalvarEspecial()
        Const DEFAULT_PATH As String = "c:\temp\"
        
        Dim FileName As String
        Dim FilePath1 As String
        Dim FilePath2 As String
        Dim RegExp As Object 'VBScript_RegExp_55.RegExp
        
        If ActiveDocument Is Nothing Then
            MsgBox "Não há um documento aberto.", vbExclamation
            GoTo Quit
        End If
        
        FileName = ActiveDocument.BuiltInDocumentProperties("Title").Value
        If FileName = "" Then
            MsgBox "Preencha a propriedade 'Título' do documento antes de continuar.", vbExclamation
            GoTo Quit
        End If
        
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.Global = True
        RegExp.IgnoreCase = True
        
        RegExp.Pattern = "(.+),"
        FilePath1 = ActiveDocument.Paragraphs(3).Range.Text
        If RegExp.Test(FilePath1) = False Then
            MsgBox "Nome de cliente não encontrado (não foi encontrada um nome antes de uma vírgula).", vbExclamation
            GoTo Quit
        End If
        FilePath1 = Split(FilePath1, ",")(0)
        
        RegExp.Pattern = "\d.+"
        FilePath2 = ActiveDocument.Paragraphs(2).Range.Text
        If RegExp.Test(FilePath2) = False Then
            MsgBox "Número de processo não encontrado.", vbExclamation
            GoTo Quit
        End If
        
        FilePath2 = RegExp.Execute(FilePath2)(0)
        RegExp.Pattern = "[ /-]"
        FilePath2 = RegExp.Replace(FilePath2, ".")
        
        RegExp.Pattern = "[^\d\.]"
        FilePath2 = RegExp.Replace(FilePath2, "")
        
        
        FilePath1 = DEFAULT_PATH & FilePath1
        FilePath2 = FilePath1 & "\" & FilePath2
        
        
        On Error Resume Next
        MkDir FilePath1
        MkDir FilePath2
        On Error GoTo 0
        FilePath2 = FilePath2 & "\"
        
        ActiveDocument.SaveAs2 FilePath2 & FileName, wdFormatXMLDocument
    Quit:
    End Sub
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 7 de novembro de 2016 17:46
    Moderador