Add a Blank (3 column) footer in word 2016 with vbsacript

[netwerkz]

Ok, I've scoured the net for hours/days, but I just cannot seem to find how to add a Blank (3 column) footer in word 2016 using a macro.

In my daily job, I receive an email from a vendor, open the attachment, and begin editing it, adding and cleaning up existing formatting, and eventually printing it as a *.pdf file for posting on our website.

Here is the code I've built over time...



Sub editpage()
'
' editPage Macro
'
'
' This Section Works On The Header
'
ActiveProtectedViewWindow.Edit
Selection.MoveDown Unit:=wdLine, Count:=5, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=17, Extend:=wdExtend
With Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphCenter
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.CollapsedByDefault = False
End With
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
With Selection.Font
.Name = "Times New Roman"
.Size = 18
.Bold = True
.Italic = False
.Underline = wdUnderlineSingle
.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
.Ligatures = wdLigaturesNone
.NumberSpacing = wdNumberSpacingDefault
.NumberForm = wdNumberFormDefault
.StylisticSet = wdStylisticSetDefault
.ContextualAlternates = 0
End With
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
If Selection.Font.Underline = wdUnderlineNone Then
Selection.Font.Underline = wdUnderlineSingle
Else
Selection.Font.Underline = wdUnderlineNone
End If
Selection.MoveUp Unit:=wdLine, Count:=3
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=9
Selection.TypeText Text:=" "
Selection.EndKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=22
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=3
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdLine
Selection.HomeKey Unit:=wdLine
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
Selection.Cut
Selection.Delete Unit:=wdCharacter, Count:=1
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.PasteAndFormat (wdFormatOriginalFormatting)
With Selection.Font
.Name = "Times New Roman"
.Size = 12
.Bold = True
.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
.Ligatures = wdLigaturesNone
.NumberSpacing = wdNumberSpacingDefault
.NumberForm = wdNumberFormDefault
.StylisticSet = wdStylisticSetDefault
.ContextualAlternates = 0
End With
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.EscapeKey
'
' This Section Separates The Body Paragraphs
'
Selection.HomeKey Unit:=wdStory
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.EscapeKey
'
' This Section Works On The Table
'
Call insertDate

End Sub


Sub insertDate()
'
' insertDate Macro
'
'
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.InsertDateTime DateTimeFormat:="dd Mmm yyyy", InsertAsField:= _
True, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.EscapeKey
End Sub
Sub editTable()
'
' editTable Macro
'
'
With Selection.Tables(1)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderHorizontal)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=12
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=2, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=5, Extend:=wdExtend
With Selection.Cells
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = -570376193
End With
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderHorizontal)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
Selection.Cells(1).FitText = False
Selection.Cells(1).FitText = False
Selection.Font.Bold = wdToggle
End Sub


Sub addFooter()
'
' addFooter Macro
'
'
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Application.Templates( _
"C:\Users\name\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In Building Blocks.dotx" _
).BuildingBlockEntries(" Blank (Three Columns)").Insert Where:=Selection. _
Range, RichText:=True
Selection.WholeStory
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.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
.Ligatures = wdLigaturesNone
.NumberSpacing = wdNumberSpacingDefault
.NumberForm = wdNumberFormDefault
.StylisticSet = wdStylisticSetDefault
.ContextualAlternates = 0
End With
Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeText Text:="Our Company Name"
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.InsertDateTime DateTimeFormat:="dd MMMM yyyy", InsertAsField:= _
True, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.EscapeKey
End Sub



This section
Application.Templates( _ "C:\Users\name\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In Building Blocks.dotx" _
).BuildingBlockEntries(" Blank (Three Columns)").Insert Where:=Selection. _
Range, RichText:=True does not work, nor does
Selection.InsertDateTime DateTimeFormat:="dd MMMM yyyy", InsertAsField:= _ True, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False

[macropod]

If this is just a blank document you're pasting the email into, why not just create a suitably-formatted Word template (i.e. a dotx-format file) with the required header/footer content and formatting and use that for your document creation? No macros required.

[gmayor]

I agree with Paul that a template into which you can insert the content of your document would make more sense. Certainly by using the selection object as in your code, the code is peculiar to a particular document format, which without access to (and the building block) it is impossible to evaluate. There are a few observations I could make.
1. Are you sure that the building block is in the BuildingBlocks template and not in the Normal template? Are you sure its name has a space before it? " Blank (Three Columns)"
2. Your date format Selection.InsertDateTime DateTimeFormat:="dd Mmm yyyy", is not valid
3. Instead of inserting empty paragraphs, apply styles that include appropriate spacing.
4. Rather than use the selection object, investigate ranges, which do not require you to open the footer in order to write to them. Maybe something like


Sub InsertTable()
Dim oTable As Table
Dim oRng As Range
Set oRng = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
oRng.Text = ""
Set oTable = ActiveDocument.Tables.Add(oRng, 1, 3)
With oTable
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderVertical)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
Set oRng = .Cell(1, 2).Range
oRng.End = oRng.End - 1
oRng.Text = "Company Name"
oRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
Set oRng = .Cell(1, 3).Range
oRng.End = oRng.End - 1
oRng.ParagraphFormat.Alignment = wdAlignParagraphRight
ActiveDocument.Fields.Add oRng, wdFieldDate, "\@ ""dd MMMM yyyy""", False
End With
Set oTable = Nothing
Set oRng = Nothing
End Sub

[netwerkz]

Hey guys,

When it comes to coding in Excel, I am comfortable, but coding in Word seems to be a completely different beast. Most of what I've built was by recording macros for each function. The parts I've indicated as not working are my "attempts" in resolving it. Nothing here is absolute, yet.

This document is not blank when I receive it. It comes in an email everyday and I open the document and start working on it. It comes pretty flat and bland. My formatting adds color and structure to it, for presenting to our clients on the web. I'm not inserting the contents of the email into the document.

Graham, the date code worked for a while, but after a recent Win10 update, it stopped working. I found it in a different forum. As for the paragraph comment, I'm not sure. I was unaware I included code to do so.

[netwerkz]

I've used this code in excel and I was hoping to have something like it in word, but I know it doesn't work like that.



year_ = Format(DateAdd("m", 0, Date), "yyyy") year_Month = Format(DateAdd("d", 0, Date), "yyyy Mmm")
year_Month_Date = Format(DateAdd("d", 0, Date), "yyyy Mmm dd")
Mnth = Format(Application.WorksheetFunction.EoMonth(Date, 1), "Mmm")

[gmayor]

What Paul suggested was that you have a template with the footer already in place and the styles that you use already configured. You can then paste the contents of your attachment into a new blank document created from the template.

The field code I posted works correctly in the latest versions of Word and Windows 10.

As for the empty paragraphs, you have a section in your code

' This Section Separates The Body Paragraphs
'
Selection.HomeKey Unit:=wdStory
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.EscapeKeyThis inserts empty paragraphs between the existing paragraphs. Instead of doing that add Paragraph Format > Space After to space the paragraphs.