Footers (VBA) and Sections (XP)

Topic

New Reply

(Edited by jscher2000 on 31-Jul-03 11:48. Added [ pre ] and [ /pre ] tags arround the code to preserve the indenting.)

I’m using the below to add footers to word documents. I’ve run into an issue where it won’t update all sections of the documents footers. Attached is a sample of the document where this does not work. If I run the code it will only update the first page(section). Then I have to select the second section and re-run.

I want to run once and have it update the document.

***CODE*****************************

Application.ScreenUpdating = False
varName = "Name"
varPhone = "Phone"

varcount = ActiveDocument.Sections.Count
 
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

    Selection.TypeText Text:=varName & Chr(10) & varPhone & Chr(10) & Date & Chr(10)
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "FILENAME", PreserveFormatting:=True
    Selection.TypeText Text:=vbTab & vbTab
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldPage
Selection.TypeParagraph
Selection.WholeStory
 With Selection.Font
        .Name = "Times New Roman"
        .Size = 8
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Spacing = 0
        .Scaling = 100
        .Position = 0
        .Kerning = 0
        .Animation = wdAnimationNone
    End With
    
    i = 2
    If varcount > 1 Then
    Do Until i > varcount
    With ActiveDocument.Sections(i).Footers(wdHeaderFooterPrimary)
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Selection.TypeText Text:=varName & Chr(10) & varPhone & Chr(10) & Date & Chr(10)
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "FILENAME", PreserveFormatting:=True
    Selection.TypeText Text:=vbTab & vbTab
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldPage
Selection.TypeParagraph
Selection.WholeStory
 With Selection.Font
        .Name = "Times New Roman"
        .Size = 8
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Spacing = 0
        .Scaling = 100
        .Position = 0
        .Kerning = 0
        .Animation = wdAnimationNone
    End With
     With Selection.HeaderFooter.PageNumbers
        .NumberStyle = wdPageNumberStyleArabic
        .HeadingLevelForChapter = 0
        .IncludeChapterNumber = False
        .ChapterPageSeparator = wdSeparatorHyphen
        .RestartNumberingAtSection = False
        .StartingNumber = 0
    End With
    End With
 
    i = i + 1
    Loop
    
   End If
    
   ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'Turn on Screen Updating
    Application.ScreenUpdating = True

***CODE*****************************

Thank you very much!!

Reply | Quote

Replies

Yes, this is a known problem. You do have to code around it by visiting all the sections. Something along the lines of:

Dim sect As Section, ftr As HeaderFooter
For Each sect In ActiveDocument.Sections
    For Each ftr In sect.Footers
        If ftr.Exists Then
            'do stuff
        End If
    Next ftr
Next sect

Check out this recent thread regarding the meaning and usefulness of .Exists versus other methods of learning about the headers and footers in each section.

I suspect there are more efficient ways to handle the do stuff also, but I’ve got to run to a meeting, so… Hope this helps.

Reply | Quote

I tried using this framework but same issue, only works for one section at a time. In fact, I’m getting a new issue that it is doubling the footer data!

Any suggestions??

Reply | Quote

I only gave half the answer: if you are using a loop of ranges, it’s best not to mix it with the Selection. Here’s a working example with comments addressing the problem of doubling the information, and also suggesting a cleaner way to handle the formatting:

Sub FooterUpdate()
Dim varName As String, varPhone As String, rngTemp As Range
varName = "Name"
varPhone = "Phone"
 
'Modification of document body omitted
 
Dim sect As Section, ftr As HeaderFooter
For Each sect In ActiveDocument.Sections
    'Update each existing footer in the section, if it's not just a carryover
    For Each ftr In sect.Footers
        If (ftr.Exists = True) And (ftr.LinkToPrevious = False) Then
            'Create temporary range for the field insert
            Set rngTemp = ftr.Range.Duplicate
            rngTemp.Collapse wdCollapseStart
            'Insert new text at the beginning of the footer
            ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldEmpty, _
                Text:="FILENAME", PreserveFormatting:=True
            rngTemp.InsertBefore varName & Chr(10) & varPhone & Chr(10) & _
                Date & Chr(10)
            'Reformat the entire footer; alternately could apply the Footer style
            With ftr.Range.Font
                .Name = "Times New Roman"
                .Size = 8
                .Bold = False
                .Italic = False
                .Underline = wdUnderlineNone
                .UnderlineColor = wdColorAutomatic
                .StrikeThrough = False
                .DoubleStrikeThrough = False
                .Outline = False
                .Emboss = False
                .Shadow = False
                .Hidden = False
                .SmallCaps = False
                .AllCaps = False
                .Color = wdColorAutomatic
                .Engrave = False
                .Superscript = False
                .Subscript = False
                .Spacing = 0
                .Scaling = 100
                .Position = 0
                .Kerning = 0
                .Animation = wdAnimationNone
            End With
            'Set page number settings for the footer
            With ftr.PageNumbers
                .NumberStyle = wdPageNumberStyleArabic
                .HeadingLevelForChapter = 0
                .IncludeChapterNumber = False
                .ChapterPageSeparator = wdSeparatorHyphen
                .RestartNumberingAtSection = False
                .StartingNumber = 0
            End With
            'Destroy the temporary range
            Set rngTemp = Nothing
        End If
    Next ftr
Next sect
End Sub

Hope this helps.

Reply | Quote

Jefferson-

Thank you so very much!!! This is exactly what I was looking for. Thank you for your time!!

I had one question: I had in a section to tab twice and place a page number. How do I incorporate this?

Once again thank you very much.

Reply | Quote

Here is what I have come up with…

 Dim sect As Section, ftr As HeaderFooter
For Each sect In ActiveDocument.Sections
 'Update each existing footer in the section, if it's not just a carryover
 For Each ftr In sect.Footers
 If (ftr.Exists = True) And (ftr.LinkToPrevious = False) Then
 'Create temporary range for the field insert
 Set rngTemp = ftr.Range.Duplicate
 rngTemp.Collapse wdCollapseStart
 'Insert new text starting at the beginning of the footer and move down as we
 'add new information

'Insert Page Number and 2 Tab Breaks
ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldPage
rngTemp.InsertAfter Chr(9) & Chr(9)

'Insert File Name
With rngTemp
    'Move in by two tab spaces and FileName
    .MoveEnd Unit:=wdCharacter, Count:=-2
    .Collapse Direction:=wdCollapseEnd
    ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldEmpty, _
    Text:="FILENAME", PreserveFormatting:=True
End With

'Insert Name, Phone and Date
 rngTemp.InsertBefore varName & Chr(10) & varPhone & Chr(10) & _
 Date & Chr(10)

'**** ALL OTHER CODE REMAINS THE SAME******

Thanks!!

Reply | Quote

I missed that completely, sorry. Immediately after the line that says:

            'Insert new text at the beginning of the footer

add this:

            ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldPage
            rngTemp.InsertBefore vbTab & vbTab
            rngTemp.Collapse wdCollapseStart

As you can see, I’m still working backwards to preserve whatever might have been in the footer originally..

Reply | Quote

Thank you very much for all your help with this!!! You rock!!

Here is what I now have:

Dim sect As Section, ftr As HeaderFooter
For Each sect In ActiveDocument.Sections
 'Update each existing footer in the section, if it's not just a carryover
 For Each ftr In sect.Footers
 If (ftr.Exists = True) And (ftr.LinkToPrevious = False) Then
 'Create temporary range for the field insert
 Set rngTemp = ftr.Range.Duplicate
 rngTemp.Collapse wdCollapseStart
 'Insert new text starting at the beginning of the footer and move down as we
 'add new information

'Insert Page Number and 2 Tab Breaks
ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldPage
rngTemp.InsertBefore vbTab & vbTab
rngTemp.Collapse wdCollapseStart

'Insert File Name
With rngTemp
    'Move in by two tab spaces and FileName
    .MoveEnd Unit:=wdCharacter, Count:=-2
    .Collapse Direction:=wdCollapseEnd
    ftr.Range.Fields.Add Range:=rngTemp, Type:=wdFieldEmpty, _
    Text:="FILENAME", PreserveFormatting:=True
End With

'Insert Name, Phone and Date
 rngTemp.InsertBefore varName & Chr(10) & varPhone & Chr(10) & _
 Date & Chr(10)

'Rest is the Same

Reply | Quote