Add Header and Footer to mulitpage word doc VBA

Question

I am trying to add a header and a footer to each page of a word document via a macro.

I have tried a few different methods such as iterating through each shape on the page but in that case , the header and footer prints out multiple times on each page depending on how many shapes are in the document.

Currently my code is looking for any current header and footer and deleting them, then it just inserts my header and footer on the first page and leaves the remaining pages in the document's header and footer blank.

Can anyone tell me where I am going wrong?

Sub HeaderFooter()
    Dim oSec As Section
    Dim oHead As HeaderFooter
    Dim oFoot As HeaderFooter

    For Each oSec In ActiveDocument.Sections
        For Each oHead In oSec.Headers
            If oHead.Exists Then oHead.Range.Delete
        Next oHead

        For Each oFoot In oSec.Footers
            If oFoot.Exists Then oFoot.Range.Delete
        Next oFoot
    Next oSec

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    With Selection.PageSetup
        .HeaderDistance = CentimetersToPoints(1.0)
        .FooterDistance = CentimetersToPoints(1.0)
    End With
    Selection.InlineShapes.AddPicture FileName:="image.jpg" _
        , LinkToFile:=False, SaveWithDocument:=True
    Selection.ParagraphFormat.Alignment = wdAlignParagraphRight

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Selection.Font.Color = RGB(179, 131, 89)
    Selection.Font.Size = 10
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.TypeText Text:="footer test"      
End Sub

Kostas K. Kostas K. · Accepted Answer · 2018-03-09T07:46:16

You need to add the header/footer into the wdHeaderFooterFirstPage range for the first page and into wdHeaderFooterPrimary for all other pages depending on the header/footer settings of the document.

The example below creates a header in all pages, consisting of a table with two cells. An image on the left side and text on the right side.

Sub UpdateHeader()

    Dim oDoc As Word.Document, oSec As Word.Section, rng As Word.Range
    Set oDoc = ActiveDocument

    For Each oSec In oDoc.Sections
        Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
        AddHeaderToRange rng

        Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
        AddHeaderToRange rng
    Next oSec
End Sub


Private Sub AddHeaderToRange(rng As Word.Range)
    With rng
        .Tables.Add Range:=rng, NumRows:=1, NumColumns:=2, DefaultTableBehavior:=wdWord8TableBehavior, AutoFitBehavior:=wdAutoFitFixed
        With .Tables(1)
            .Borders.InsideLineStyle = wdLineStyleNone
            .Borders.OutsideLineStyle = wdLineStyleNone
            .Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
            .Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
            .Cell(1, 1).Range.InlineShapes.AddPicture filename:="image path", LinkToFile:=False, SaveWithDocument:=True
            .Cell(1, 2).Range.Font.Name = "Arial"
            .Cell(1, 2).Range.Font.Size = 9
            .Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
            .Cell(1, 2).Range.Text = "Test header"
        End With
    End With
End Sub

The same principle applies for the Footer.

Sub UpdateFooter()

    Dim oDoc As Word.Document, oSec As Word.Section, rng As Word.Range
    Set oDoc = ActiveDocument

    For Each oSec In oDoc.Sections
        Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
        AddFooterToRange rng

        Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
        AddFooterToRange rng

        Set rng = oSec.Footers(Word.WdHeaderFooterIndex.wdHeaderFooterEvenPages).Range
        AddFooterToRange rng
    Next oSec
End Sub

Private Sub AddFooterToRange(rng As Word.Range)
    With rng
        .Font.Name = "Arial"
        .Font.Size = 9
        .Text = "Footer sample text"
        With .ParagraphFormat
            .Alignment = wdAlignParagraphJustify
            .LineSpacingRule = wdLineSpaceExactly
            .LineSpacing = Application.LinesToPoints(1)
            .LeftIndent = Application.CentimetersToPoints(-1.6)
            .RightIndent = Application.CentimetersToPoints(-1.6)
        End With
    End With
End Sub

Lastly, to delete existing headers:

Sub ClearExistingHeaders(oDoc As Word.Document)
    Dim oSec As Word.Section, oHeader As HeaderFooter
    For Each oSec In oDoc.Sections
        For Each oHeader In oSec.Headers
            oHeader.Range.Delete
        Next
    Next
End Sub

Add Header and Footer to mulitpage word doc VBA

1 Answers