none
VBA Word Formatar Cabeçalho RRS feed

  • Pergunta

  • Prezados, venho pedir ajuda para alterar esse código, pois não estou conseguindo.

    O mesmo edita e formata cada arquiva do word existente na pasta, mas apenas o texto, gostaria que também formatasse o cabeçalho.

    Agradeço quem poder ajudar.

    Sub pMain()
      'Altere aqui o caminho do diretório que contém os arquivos que você quer formatar.
      Const csDiretório As String = "c:\WORD\"
      
      Dim doc As Word.Document
      Dim oFile As Object 'Scripting.File
      Dim oFolder As Object 'Scripting.Folder
      Dim oFSO As Object 'Scripting.FileSystemObject
      
      Set oFSO = CreateObject("Scripting.FileSystemObject")
      Set oFolder = oFSO.GetFolder(csDiretório)
      For Each oFile In oFolder.Files
        If LCase(oFSO.GetExtensionName(oFile.Path)) Like "doc*" Then
          Set doc = Documents.Open(oFile.Path)
          doc.Content.Select
          Selection.ClearFormatting
          Selection.Style = doc.Styles(wdStyleNormal)
          Selection.Font.Color = wdColorBlack
          Selection.Font.Bold = False
          Selection.Font.Italic = False
          Selection.Font.Size = 11
          Selection.Font.Name = "ARIAL"
          Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
          doc.PageSetup.TopMargin = 25
          doc.PageSetup.BottomMargin = 25
          doc.PageSetup.LeftMargin = 25
          doc.PageSetup.RightMargin = 25
          doc.ActiveWindow.ActivePane.View.Zoom.Percentage = 80
          doc.Close SaveChanges:=wdSaveChanges
          DoEvents
        End If
      Next oFile
    End Sub

    sábado, 14 de dezembro de 2019 19:58

Respostas

  • AdrianoPires,

       Agora ficou fácil. Eu testei com três arquivos na pasta "C:\WORD" e funcionou perfeitamente.

       Eu alterei sua "Sub pMain()" para ficar assim:

    Sub pMain()
    'Altere aqui o caminho do diretório que contém os arquivos que você quer formatar.
    Const csDiretório As String = "C:\WORD\"
      
    Dim doc As Word.Document
    Dim oFile As Object 'Scripting.File
    Dim oFolder As Object 'Scripting.Folder
    Dim oFSO As Object 'Scripting.FileSystemObject
    Dim objDoc As Document
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(csDiretório)
       
    For Each oFile In oFolder.Files
      
        If LCase(oFSO.GetExtensionName(oFile.Path)) Like "doc*" Then
            Set doc = Documents.Open(oFile.Path)
            doc.Content.Select
          
            Set objDoc = ActiveDocument
                 
            SubstituiCabecalho
    
            doc.ActiveWindow.ActivePane.View.Zoom.Percentage = 80
            doc.Close SaveChanges:=wdSaveChanges
            
            DoEvents
        End If
        
    Next oFile
      
    End Sub

       Veja que ela chama uma Sub chamada "Sub SubstituiCabecalho()".

       E que eu o nome da sub de alteração de cabeçalho para "Sub SubstituiCabecalho()". Ela ficou assim:

    Sub SubstituiCabecalho()
      Dim nPageNum As Integer
      Dim objDoc As Document
      
      Set objDoc = ActiveDocument
    
      For nPageNum = 1 To Selection.Information(wdNumberOfPagesInDocument)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=nPageNum
        Application.Browser.Target = wdBrowsePage
        objDoc.Bookmarks("\page").Range.Select
        
        With objDoc.ActiveWindow
          .ActivePane.View.SeekView = wdSeekCurrentPageHeader
          .ActivePane.View.Zoom.Percentage = 80
          
          With .Selection
            .ClearFormatting
            .Style = wdStyleNormal
            .PageSetup.TopMargin = 25
            .PageSetup.BottomMargin = 25
            .PageSetup.LeftMargin = 25
            .PageSetup.RightMargin = 25
            .Font.Color = wdColorBlack
            .Font.Bold = False
            .Font.Italic = False
            .Font.Size = 11
            .Font.Name = "ARIAL"
            .ParagraphFormat.Alignment = wdAlignParagraphJustify
            End With
               
        End With
        
      Next nPageNum
      
      objDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    End Sub

       Faça um backup de seus arquivos e tente rodar inicialmente com 2 ou 3 arquivos e veja o resultado. Sugiro que acompanhe cada linha de execução com o "step-by-step" (tecla F8) para ver o que stá acontecendo. Se tiver algum problema me avise. Se não tiver problema nenhum e funcionar, por favor não esqueça de me pontuar como melhor resposta. 

       Tenho certeza que vai funcionar!

    []'s,
    Fabio I.
    • Editado Fabio I segunda-feira, 30 de dezembro de 2019 00:48
    • Marcado como Resposta AdrianoPires segunda-feira, 30 de dezembro de 2019 22:26
    segunda-feira, 30 de dezembro de 2019 00:47

Todas as Respostas

  • AdrianoPires,

        Achei uma função que se modificada pode resolver seu problema. "ReplaceTextInHeaderInADoc" , estou meio sem tempo de deixá-la redondinha, mas acho que não está difícil... ficará +/- assim:

    Sub pMain()
    'Altere aqui o caminho do diretório que contém os arquivos que você quer formatar.
    Const csDiretório As String = "C:\WORD\"
      
    Dim doc As Word.Document
    Dim oFile As Object 'Scripting.File
    Dim oFolder As Object 'Scripting.Folder
    Dim oFSO As Object 'Scripting.FileSystemObject
    Dim objDoc As Document
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(csDiretório)
       
    For Each oFile In oFolder.Files
      
        If LCase(oFSO.GetExtensionName(oFile.Path)) Like "doc*" Then
            Set doc = Documents.Open(oFile.Path)
            doc.Content.Select
          
            Set objDoc = ActiveDocument
                 
            ReplaceTextInHeaderInADoc
          
            Selection.ClearFormatting
            Selection.Style = doc.Styles(wdStyleNormal)
            Selection.Font.Color = wdColorBlack
            Selection.Font.Bold = False
            Selection.Font.Italic = False
            Selection.Font.Size = 11
            Selection.Font.Name = "ARIAL"
            Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
            
            doc.PageSetup.TopMargin = 25
            doc.PageSetup.BottomMargin = 25
            doc.PageSetup.LeftMargin = 25
            doc.PageSetup.RightMargin = 25
            doc.ActiveWindow.ActivePane.View.Zoom.Percentage = 80
            doc.Close SaveChanges:=wdSaveChanges
            
            DoEvents
        End If
        
    Next oFile
      
    End Sub


       Mas, por favor! Leia também os seguintes Links:

    ====================================
    Searching for Text in Header Section of A Word Document

    https://stackoverflow.com/questions/9186629/searching-for-text-in-header-section-of-a-word-document
    ====================================
    Replacing Text in Word .doc Header from Excel VBA Macro

    https://www.mrexcel.com/board/threads/replacing-text-in-word-doc-header-from-excel-vba-macro.980242/
    ====================================
    3 Effective Methods to Replace Text in the Header of Your Word Document 

    Sub ReplaceTextInHeaderInADoc()
      Dim nPageNum As Integer
      Dim objDoc As Document
      Dim strFindText As String
      Dim strReplaceText As String
    
      Set objDoc = ActiveDocument
      strFindText = InputBox("Enter text to be found:", "Find Text")
      strReplaceText = InputBox("Enter new text:", "Replace Text")
    
      For nPageNum = 1 To Selection.Information(wdNumberOfPagesInDocument)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=nPageNum
        Application.Browser.Target = wdBrowsePage
        objDoc.Bookmarks("\page").Range.Select
        With objDoc.ActiveWindow
          .ActivePane.View.SeekView = wdSeekCurrentPageHeader
          With .Selection.Find
            .ClearFormatting
            .Text = strFindText
            .Replacement.ClearFormatting
            .Replacement.Text = strReplaceText
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
          End With
        End With
      Next nPageNum
      objDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    End Sub


    https://www.datanumen.com/blogs/3-effective-methods-replace-text-header-word-document/
    ====================================


    []'s,
    Fabio I.                      

    Post Script: Se resolveu seu problema eu ficarei contente por você e você me pontua me deixando muito mais contente! Valew!!!
    • Editado Fabio I quarta-feira, 18 de dezembro de 2019 11:43
    quarta-feira, 18 de dezembro de 2019 11:40
  • Fábio, agradeço sua atenção, mas não consegui fazer funcionar, acho que o problema são meus conhecimentos mesmo.

    de qualquer forma, muito obrigado pela atenção.

    sexta-feira, 27 de dezembro de 2019 19:13
  • Mas AdrianoPires,

       Você chegou a ler os links que eu passei?!?

    []'s,
    Fabio I.

    sexta-feira, 27 de dezembro de 2019 19:17
  • Fábio, li sim, mas ali são códigos para encontrar e substituir palavras/texto do cabeçalho, não consegui fazer a adaptação para limpar a formatação existente e fazer nova formatação.

    Att

    AdrianoPires

    sexta-feira, 27 de dezembro de 2019 19:57
  • AdrianoPires,

        Estou com tempo agora, se você quiser posso fazer para você. Mas preciso de mais detalhes do que você quer.

    []'s,
    Fabio I.

    sábado, 28 de dezembro de 2019 13:01
  • Fabio, agradeço sua ajuda, eu tenho mais de 600 arquivos do word e todos com cabeçalho, porém cada um tem uma formatação diferente, tipo e tamanho de fonte, o que preciso é que a macro abrisse cada um dos arquivos, selecionasse todo o texto do cabeçalho, alterasse para Arial 11 e salvasse o arquivo. O código que coloquei no começo faz isso com o texto do corpo, mas preciso que seja feito no cabeçalho também.

    Grato

    AdrianoPires

    domingo, 29 de dezembro de 2019 14:42
  • AdrianoPires,

       Agora ficou fácil. Eu testei com três arquivos na pasta "C:\WORD" e funcionou perfeitamente.

       Eu alterei sua "Sub pMain()" para ficar assim:

    Sub pMain()
    'Altere aqui o caminho do diretório que contém os arquivos que você quer formatar.
    Const csDiretório As String = "C:\WORD\"
      
    Dim doc As Word.Document
    Dim oFile As Object 'Scripting.File
    Dim oFolder As Object 'Scripting.Folder
    Dim oFSO As Object 'Scripting.FileSystemObject
    Dim objDoc As Document
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(csDiretório)
       
    For Each oFile In oFolder.Files
      
        If LCase(oFSO.GetExtensionName(oFile.Path)) Like "doc*" Then
            Set doc = Documents.Open(oFile.Path)
            doc.Content.Select
          
            Set objDoc = ActiveDocument
                 
            SubstituiCabecalho
    
            doc.ActiveWindow.ActivePane.View.Zoom.Percentage = 80
            doc.Close SaveChanges:=wdSaveChanges
            
            DoEvents
        End If
        
    Next oFile
      
    End Sub

       Veja que ela chama uma Sub chamada "Sub SubstituiCabecalho()".

       E que eu o nome da sub de alteração de cabeçalho para "Sub SubstituiCabecalho()". Ela ficou assim:

    Sub SubstituiCabecalho()
      Dim nPageNum As Integer
      Dim objDoc As Document
      
      Set objDoc = ActiveDocument
    
      For nPageNum = 1 To Selection.Information(wdNumberOfPagesInDocument)
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=nPageNum
        Application.Browser.Target = wdBrowsePage
        objDoc.Bookmarks("\page").Range.Select
        
        With objDoc.ActiveWindow
          .ActivePane.View.SeekView = wdSeekCurrentPageHeader
          .ActivePane.View.Zoom.Percentage = 80
          
          With .Selection
            .ClearFormatting
            .Style = wdStyleNormal
            .PageSetup.TopMargin = 25
            .PageSetup.BottomMargin = 25
            .PageSetup.LeftMargin = 25
            .PageSetup.RightMargin = 25
            .Font.Color = wdColorBlack
            .Font.Bold = False
            .Font.Italic = False
            .Font.Size = 11
            .Font.Name = "ARIAL"
            .ParagraphFormat.Alignment = wdAlignParagraphJustify
            End With
               
        End With
        
      Next nPageNum
      
      objDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    End Sub

       Faça um backup de seus arquivos e tente rodar inicialmente com 2 ou 3 arquivos e veja o resultado. Sugiro que acompanhe cada linha de execução com o "step-by-step" (tecla F8) para ver o que stá acontecendo. Se tiver algum problema me avise. Se não tiver problema nenhum e funcionar, por favor não esqueça de me pontuar como melhor resposta. 

       Tenho certeza que vai funcionar!

    []'s,
    Fabio I.
    • Editado Fabio I segunda-feira, 30 de dezembro de 2019 00:48
    • Marcado como Resposta AdrianoPires segunda-feira, 30 de dezembro de 2019 22:26
    segunda-feira, 30 de dezembro de 2019 00:47
  • Fabio, era isso mesmo que eu queria, como meus cabeçalhos tem bordas, no começo não funcionou, mas fiz uma alteração no código e agora está 100%. Agradeço muito sua colaboração.

    Segue a alteração que fiz.

    GratoAdrianoPires

    With .Selection
           Selection.WholeStory
            '.ClearFormatting
            '.Style = wdStyleNormal
            '.PageSetup.TopMargin = 25
            '.PageSetup.BottomMargin = 25
            '.PageSetup.LeftMargin = 25
            '.PageSetup.RightMargin = 25
            .Font.Bold = False
            .Font.Italic = False
            .Font.Color = wdColorBlack
            .Font.Size = 11
            .Font.Name = "ARIAL"
            .ParagraphFormat.Alignment = wdAlignParagraphJustify

    segunda-feira, 30 de dezembro de 2019 22:28
  • AdrianoPires, obrigado por me pontuar.
    terça-feira, 31 de dezembro de 2019 11:30