Consulting

Results 1 to 6 of 6

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

  1. #1
    VBAX Regular
    Joined
    Nov 2014
    Location
    Idaho
    Posts
    35
    Location

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

    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

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,970
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    VBAX Regular
    Joined
    Nov 2014
    Location
    Idaho
    Posts
    35
    Location
    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.

  5. #5
    VBAX Regular
    Joined
    Nov 2014
    Location
    Idaho
    Posts
    35
    Location
    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")

  6. #6
    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.EscapeKey
    This inserts empty paragraphs between the existing paragraphs. Instead of doing that add Paragraph Format > Space After to space the paragraphs.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •