Loop Through Headers Excluding First Page

[shudder]

Hi Guys,

I have the following code which loops through each of the headers in a document and deletes any tables which are present.

Sub DeleteTablesInHeaders()
Dim sec As Section
Dim hdr As HeaderFooter
Dim i As Integer
 
For Each sec In ActiveDocument.Sections
    For Each hdr In sec.Headers
        If hdr.Exists Then
            For i = hdr.Range.Tables.Count To 1 Step -1
                hdr.Range.Tables(i).Delete
            Next i
        End If
    Next hdr
Next sec
End Sub

How can this be amended to exclude the first page?

Thanks in advance.

[macropod]

Is your document configured with a 'different first page' layout?

[shudder]

Hi Paul, on some documents but not others. Unfortunately I do not have control of the letter templates created so cannot amend these. Assume this could be amended via codingy?

Essentially I am trying to copy letters generated from our software onto company headed paper (the letterhead template does have ' different first page' layout switched on.

Here is my full code for copying headers/footers:

Sub CopyLetterhead()
'***************************************************************************************
'Purpose: Copies the current document on to company letterhead (some letters generated
'from Acturis do not have letterheads as default
'***************************************************************************************
Dim docTemplate As Document
Dim strTemplate As String
Dim hdr1 As HeaderFooter
Dim hdr2 As HeaderFooter
Dim doc As Document
Dim Answer As Integer
Answer = MsgBox("This will copy the current content of this document onto company letterhead." & _
            vbCr & vbCr & "Would you like to continue?", vbYesNo + vbQuestion, "Copy to Letterhead")
If Answer = vbNo Then
     Exit Sub
End If
Application.ScreenUpdating = False
'Set page setup sizes for page and margins
With ActiveDocument.PageSetup
    .DifferentFirstPageHeaderFooter = True
    .TopMargin = CentimetersToPoints(5.84)
    .BottomMargin = CentimetersToPoints(3)
    .LeftMargin = CentimetersToPoints(2.54)
    .RightMargin = CentimetersToPoints(2.54)
    .Gutter = CentimetersToPoints(0)
    .HeaderDistance = CentimetersToPoints(3.81)
    .FooterDistance = CentimetersToPoints(0.63)
    .PageWidth = CentimetersToPoints(21)
    .PageHeight = CentimetersToPoints(29.7)
End With
'Copy header and footer from the template doc
Set doc = ActiveDocument
strTemplate = fPath & "Letterhead.docx" 'fPath declared as a public constant
Set docTemplate = Documents.Open(strTemplate, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set hdr1 = docTemplate.Sections(1).Headers(wdHeaderFooterFirstPage)
Set hdr2 = doc.Sections(1).Headers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
Set hdr1 = docTemplate.Sections(1).Footers(wdHeaderFooterFirstPage)
Set hdr2 = doc.Sections(1).Footers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
docTemplate.Close False
Call LinkAllHeadersFooters
Call ClearClipboard
Application.ScreenUpdating = True
End Sub


Sub LinkAllHeadersFooters()
    Dim s As Section
    On Error Resume Next
    For Each s In ActiveDocument.Sections
        s.Headers(wdHeaderFooterEvenPages).LinkToPrevious = True
        s.Headers(wdHeaderFooterFirstPage).LinkToPrevious = True
        s.Headers(wdHeaderFooterPrimary).LinkToPrevious = True
        s.Footers(wdHeaderFooterEvenPages).LinkToPrevious = True
        s.Footers(wdHeaderFooterFirstPage).LinkToPrevious = True
        s.Footers(wdHeaderFooterPrimary).LinkToPrevious = True
    Next s
End Sub

[macropod]

Unless your documents have a 'different first page' layout - or perhaps a 'different odd and even pages' layout - there is no way to delete the table on the first page without deleting it from all other pages as well. Even with the 'different odd and even pages' layout, the table would be deleted from every second page.

As for your code, you should be using a letterhead template rather than trying to force a document to fulfil that role and trying to reformat your existing documents to suit.

[shudder]

Unfortunately we are just one branch of a multinational organisation and as much as I try to get the original templates amended this is an uphill struggle. Hence trying to use a macro to copy the letter onto company letterhead.

The headers and footers are the same throughout the document other than the first page which also has a table noting the branch address. Is there any way the headers/footers can be copied and then the table with the address being added after?

[macropod]

If you want the company to use templates that can easily be updated to reflect address changes, etc., you need to have a document or template that never gets used containing just the letterhead, then link the first-page header of all the other templates that do get used to the unused one via an INCLUDETEXT field. That way, there's only one file at each location that might need changing. The templates that get used would be saved in the .dotm format and would contain a Document_New macro that unlinks the INCLUDETEXT field in the header so that existing documents don't get their letterheads updated when the letterhead in the template gets changed.

If you want to copy an existing document's content into one using your letterhead template, you'd use code like:

Sub Demo()
Dim DocSrc As Document, DocTgt As Document, StrNm As String, FlFmt As Long, s As Long, HdFt As HeaderFooter
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add("Filepath\Template.dotm", Visible:=False)
With DocSrc
  StrNm = .FullName: FlFmt = .SaveFormat
  DocTgt.Range.FormattedText = .Range.FormattedText
    For Each HdFt In .Sections.First.Headers
      Select Case HdFt.Index
        Case wdHeaderFooterPrimary, wdHeaderFooterEvenPages
          With DocTgt.Sections.First.Headers(HdFt.Index).Range
            .FormattedText = HdFt.Range.FormattedText
            .Characters.Last.Delete
          End With
        Case Else
      End Select
    Next
  For s = 2 To .Sections.Count
    For Each HdFt In .Sections(i).Headers
      If HdFt.LinkToPrevious = True Then
        DocTgt.Sections.First.Headers(HdFt.Index).LinkToPrevious = True
      Else
        With DocTgt.Sections.First.Headers(HdFt.Index).Range
          .FormattedText = HdFt.Range.FormattedText
          .Characters.Last.Delete
        End With
      End If
    Next
  Next
  .Close False
End With
DocTgt.SaveAs2 FileName:=StrNm, FileFormat:=FlFmt
Set DocSrc = Nothing: Set DocTgt = Nothing
End Sub

The problem, though, will be in knowing which header should apply to Sections after the first in multi-Section documents when the Section concerned has only one page. That's not something that can be decided by the code.

Another problem is that you're using a document but calling it a template. Templates have .dot, .dotx, or .dotm extensions, never .doc, .docx, or .docm.

[shudder]

Thanks Paul,

Rather than working with Words inbuilt templates, I was looking at a template stored locally in a shared drive.

I made a rookie VBA error here in assuming what I needed and asking for assistance when actually I didn't need a loop in this instance, but a better understanding of the header/footer properties as I have now got this to working by repeating elements of the code to pull the wdHeaderFooterPrimary from the template:

Set doc = ActiveDocument
strTemplate = fPath & "Letterhead.docx" 'fPath declared as a public constant
Set docTemplate = Documents.Open(strTemplate, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set hdr1 = docTemplate.Sections(1).Headers(wdHeaderFooterFirstPage) 'Copies the first page header
Set hdr2 = doc.Sections(1).Headers(wdHeaderFooterFirstPage)
hdr1.Range.Copy
hdr2.Range.Paste
Set hdr1 = docTemplate.Sections(1).Headers(wdHeaderFooterPrimary) 'Copies the diffrent first page header
Set hdr2 = doc.Sections(1).Headers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
Set hdr1 = docTemplate.Sections(1).Footers(wdHeaderFooterFirstPage) 'Copies the footer
Set hdr2 = doc.Sections(1).Footers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
docTemplate.Close False

Full code here I case anybody finds it useful:

Sub CopyLetterhead()
'***************************************************************************************

'Purpose: Copies the current document on to Company letterhead

'***************************************************************************************

Dim docTemplate As Document
Dim strTemplate As String
Dim hdr1 As HeaderFooter
Dim hdr2 As HeaderFooter
Dim doc As Document
Dim Answer As Integer
Dim sec As Section

Answer = MsgBox("This will copy the current content ofthis document onto Company letterhead." & _
vbCr &vbCr & "Would you like to continue?", vbYesNo + vbQuestion,"Copy to Letterhead")
If Answer = vbNo Then
Exit Sub
End If

Application.ScreenUpdating = False

'Set page setup sizes for page and margins
With ActiveDocument.PageSetup
.DifferentFirstPageHeaderFooter= True
.TopMargin =CentimetersToPoints(5.84)
.BottomMargin =CentimetersToPoints(3)
.LeftMargin =CentimetersToPoints(2.54)
.RightMargin =CentimetersToPoints(2.54)
.Gutter =CentimetersToPoints(0)
.HeaderDistance =CentimetersToPoints(3.81)
.FooterDistance =CentimetersToPoints(0.63)
.PageWidth =CentimetersToPoints(21)
.PageHeight =CentimetersToPoints(29.7)
End With

'Copy header and footer from the template doc
Set doc = ActiveDocument
strTemplate = “C:\Desktop\Letterhead.docx" 
Set docTemplate = Documents.Open(strTemplate,AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set hdr1 =docTemplate.Sections(1).Headers(wdHeaderFooterFirstPage) 'Copies the first pageheader
Set hdr2 = doc.Sections(1).Headers(wdHeaderFooterFirstPage)
hdr1.Range.Copy
hdr2.Range.Paste
Set hdr1 =docTemplate.Sections(1).Headers(wdHeaderFooterPrimary) 'Copies the diffrentfirst page header
Set hdr2 = doc.Sections(1).Headers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
Set hdr1 =docTemplate.Sections(1).Footers(wdHeaderFooterFirstPage) 'Copies the footer
Set hdr2 = doc.Sections(1).Footers(wdHeaderFooterPrimary)
hdr1.Range.Copy
hdr2.Range.Paste
docTemplate.Close False

On Error Resume Next
For Each s In ActiveDocument.Sections
sec.Headers(wdHeaderFooterEvenPages).LinkToPrevious = True
sec.Headers(wdHeaderFooterFirstPage).LinkToPrevious = True
sec.Headers(wdHeaderFooterPrimary).LinkToPrevious = True
sec.Footers(wdHeaderFooterEvenPages).LinkToPrevious = True
sec.Footers(wdHeaderFooterFirstPage).LinkToPrevious = True
sec.Footers(wdHeaderFooterPrimary).LinkToPrevious = True
Next sec
On Error GoTo 0

Call ClearClipboard

Application.ScreenUpdating = True

[macropod]

Rather than working with Words inbuilt templates, I was looking at a template stored locally in a shared drive.

I didn't suggest using Word's 'inbuilt' templates as you call them. Indeed, in post 6 I said you'd create the required templates.

Regardless, even your latest code shows a determination to call documents templates when they are not, as well as using the wrong methods for creating new documents.

Learn what a template is and how to use it!