Printable View
Hi Guys,
I have the following code which loops through each of the headers in a document and deletes any tables which are present.
How can this be amended to exclude the first page?Code: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
Thanks in advance.
Is your document configured with a 'different first page' layout?
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:
Code: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
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.
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?
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:
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.Code: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
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.
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:
Full code here I case anybody finds it useful:Code: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
Code: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
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.Quote:
Originally Posted by shudder
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!