VBA Code
Page Setup
When you do not specify a section, the first section is used.
If (ActiveDocument.Sections(1).PageSetup.PaperSize = wdPaperSize.wdPaperA4) Then
If (ActiveDocument.PageSetup.PaperSize = wdPaperSize.wdPaperA4) Then
Get the Index number of the current section
Dim lAppSec As Long
lAppSec = Selection.Information(wdInformation.wdActiveEndSectionNumber)
Inserting Section Breaks
objRange.InsertBreak(wdBreakType.wdSectionBreakNextPage)
objRange.InsertBreak(wdBreakType.wdSectionBreakNextPage)
Removing Section Breaks
After running these lines of code the whole document will be selected.
With ActiveDocument.Content.Find
.Text = "^b"
.Replacement.Text = ""
.Execute Replace:=wdReplace.wdReplaceAll
End With
The section object represents a section in a document, range or selection
Each of the Document, Range and Selection objects has a Sections property that returns a sections collection.
objSectionsCol = ObjDocument.Sections
The Range parameter refers to the range before which the section break will be inserted
The Start is the type of section break to insert
objSection.Add Range:=Start:=wdSectionStart.wdSectionContinuous
An alternative way to insert a new section is using the InsertBreak method which applies to a Range or Selection object
expression.InsertBreak(wdBreakType.wdSectionBreakNextPage)
When you insert a section break it is inserted immediately before the specified range or selection
However for the other types of breaks the range or selection is actually replaced
The Sections collection has a PageSetup property that returns a PageSetup object.
These settings are only accurate for all the settings that are common to all the sections in the sections collection.
objPageSetup.SectionStart = wdSectionStart.wdSectionNewPage
First and Last
ActiveDocument.Sections.Item(1)
ActiveDocument.Sections.First
ActiveDocument.Sections.Item(ActiveDocument.Sections.Count)
ActiveDocument.Sections.Last
Define a range from the start of the document to the end of the first selected paragraph
Msgbox (ActiveDocument.Range(0,Selection.Paragraphs(1).Range.End).Sections.Count)
VBA - Landscape Pages
Public Sub Layout_InsertLandscapePage()
Dim lsectionno As Long
Dim oCurrentSection As Section
Dim oPreviousSection As Section
Dim oRange As Range
lsectionno = Selection.Information(wdActiveEndSectionNumber)
Set oCurrentSection = ActiveDocument.Sections(lsectionno)
If (oCurrentSection.PageSetup.Orientation = wdOrientLandscape) Then
Exit Sub
End If
Set oCurrentSection = Selection.Sections(1)
Selection.MoveUp wdLine, 1
Set oPreviousSection = Selection.Sections(1)
Selection.MoveDown wdLine, 1
If (oPreviousSection.Index = oCurrentSection.Index) Then
Selection.TypeParagraph
Selection.InsertBreak (wdSectionBreakNextPage)
With Selection
.TypeParagraph
Set oRange = Selection.Range
oRange.MoveStart wdParagraph, -1
oRange.Select
.Style = ActiveDocument.Styles("Heading 1")
.TypeText "New Landscape Section"
Set oRange = Selection.Range
oRange.MoveStart wdParagraph, 1
oRange.Select
If (Selection_IsAtEndOfDocument = False) Then
.TypeParagraph
.TypeParagraph
.InsertBreak (wdSectionBreakNextPage)
.Delete
Set oRange = Selection.Range
oRange.Move wdParagraph, -3
oRange.Select
End If
Call Layout_SwitchToLandscapeSection(True)
End With
Else
End If
Set oRange = Nothing
End Sub
Public Sub Layout_SwitchToLandscapeSection(ByVal bLinkToPrevious As Boolean)
Dim lsectionno As Long
Dim oCurrentSection As Section
Dim oNextSection As Section
Dim oHeaderRange As Range
Dim oFooterRange As Range
lsectionno = Selection.Information(wdActiveEndSectionNumber)
Set oCurrentSection = ActiveDocument.Sections(lsectionno)
If (oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientLandscape) Then
'do nothing
Else
If (ActiveDocument.Sections.Count > lsectionno) Then
Set oNextSection = ActiveDocument.Sections(lsectionno + 1)
oNextSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oNextSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
End If
oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oCurrentSection.PageSetup.Orientation = WdOrientation.wdOrientLandscape
'always reset these, regardless of linktoprevious or not
Set oHeaderRange = oCurrentSection.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
oHeaderRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(25.75)
Set oFooterRange = oCurrentSection.Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
oFooterRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(8.5)
oFooterRange.ParagraphFormat.TabStops.Item(2).Position = CentimetersToPoints(25.75)
End If
Set oNextSection = Nothing
Set oHeaderRange = Nothing
Set oFooterRange = Nothing
Set oCurrentSection = Nothing
End Sub
Public Sub Layout_InsertPortraitPage()
Dim lsectionno As Long
Dim oCurrentSection As Section
Dim oPreviousSection As Section
Dim oRange As Range
lsectionno = Selection.Information(wdActiveEndSectionNumber)
Set oCurrentSection = ActiveDocument.Sections(lsectionno)
If (oCurrentSection.PageSetup.Orientation = wdOrientPortrait) Then
Exit Sub
End If
Set oCurrentSection = Selection.Sections(1)
Selection.MoveUp wdLine, 1
Set oPreviousSection = Selection.Sections(1)
Selection.MoveDown wdLine, 1
If (oPreviousSection.Index = oCurrentSection.Index) Then
Selection.TypeParagraph
Selection.InsertBreak (wdSectionBreakNextPage)
With Selection
.TypeParagraph
Set oRange = Selection.Range
oRange.MoveStart wdParagraph, -1
oRange.Select
.Style = ActiveDocument.Styles("Heading 1")
.TypeText "New Portrait Section"
Set oRange = Selection.Range
oRange.MoveStart wdParagraph, 1
oRange.Select
If (Selection_IsAtEndOfDocument = False) Then
.TypeParagraph
.TypeParagraph
.InsertBreak (wdSectionBreakNextPage)
.Delete
Set oRange = Selection.Range
oRange.Move wdParagraph, -3
oRange.Select
End If
Call Layout_SwitchToPortraitSection(True)
End With
Else
End If
Set oRange = Nothing
Set oCurrentSection = Nothing
End Sub
Public Sub Layout_SwitchToPortraitSection(ByVal bLinkToPrevious As Boolean)
Dim lsectionno As Long
Dim ipageno As Integer
Dim oCurrentSection As Section
Dim oNextSection As Section
Dim oHeaderRange As Range
Dim oFooterRange As Range
lsectionno = Selection.Information(wdActiveEndSectionNumber)
Set oCurrentSection = ActiveDocument.Sections(lsectionno)
If (oCurrentSection.PageSetup.Orientation = wdOrientPortrait) Then
Else
If (ActiveDocument.Sections.Count > lsectionno) Then
Set oNextSection = ActiveDocument.Sections(lsectionno + 1)
oNextSection.Headers(wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oNextSection.Footers(wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
End If
oCurrentSection.Headers(wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oCurrentSection.Footers(wdHeaderFooterPrimary).LinkToPrevious = bLinkToPrevious
oCurrentSection.PageSetup.Orientation = wdOrientPortrait
If (bLinkToPrevious = False) Then
Set oHeaderRange = oCurrentSection.Headers(wdHeaderFooterPrimary).Range
oHeaderRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(17)
Set oFooterRange = oCurrentSection.Footers(wdHeaderFooterPrimary).Range
oFooterRange.ParagraphFormat.TabStops.Item(1).Position = CentimetersToPoints(8.5)
oFooterRange.ParagraphFormat.TabStops.Item(2).Position = CentimetersToPoints(17)
End If
End If
Set oNextSection = Nothing
Set oHeaderRange = Nothing
Set oFooterRange = Nothing
Set oCurrentSection = Nothing
End Sub
VBA - Landscape Pages Alt
Public Sub InsertLandscape_Alt(ATName As String, _
Optional AppDiffHead As Boolean, _
Optional AppNoPgNo As Boolean, _
Optional bUpdateHeaderFooter As Boolean)
Dim currsec As Long
Dim LandsSec As Long
Dim AppSec As Long
Dim rgAppHead As Range
Dim selInApp As Boolean
Dim ofld As Field
currsec = Selection.Information(wdActiveEndSectionNumber) 'get the current section number
CheckTrackingON (False)
Application.ScreenUpdating = False
'we are at the beginning of the paragraph (A_code does that) check what's before and after
'mark the current position
ActiveDocument.Bookmarks.Add Name:="BM_CurrPos", Range:=Selection.Range
'go around 20 lines up if needed to find empty paragraph markers (and delete them)
For i = 1 To 20
'check para before
Selection.MoveUp unit:=wdParagraph, Count:=1
'empty pararaph marker delete and go further up
If Selection.Paragraphs(1).Range.text = Chr(13) Then
i = i + 1
Selection.Paragraphs(1).Range.Delete
ElseIf InStr(Selection.Paragraphs(1).Range.text, Chr(12)) Then
'manual pagebreak - if we insert a section break now, they end up with an empty white page
'unfortunately, this also kicks in for a section break!
'go to the end of the para and delete the page break
Selection.SetRange _
Start:=Selection.Paragraphs(1).Range.End - 2, _
End:=Selection.Paragraphs(1).Range.End - 1
On Error Resume Next
'this could be one of our section breaks
Selection.Range.Delete
Err.Clear
On Error GoTo 0
ActiveDocument.Bookmarks("BM_CurrPos").Select
ActiveDocument.Bookmarks("BM_CurrPos").Delete
Exit For
Else
ActiveDocument.Bookmarks("BM_CurrPos").Select
ActiveDocument.Bookmarks("BM_CurrPos").Delete
Exit For
End If
Next i
'we are now at the start of a paragraph insert the section break necessary for the Landscape page
Selection.InsertBreak (wdSectionBreakNextPage)
'get the section number
LandsSec = Selection.Information(wdActiveEndSectionNumber)
'make the new section not first page different
If ActiveDocument.Sections(currsec).PageSetup.DifferentFirstPageHeaderFooter = True Then
ActiveDocument.Sections(LandsSec).PageSetup.DifferentFirstPageHeaderFooter = False
End If
With ActiveDocument.Sections(LandsSec)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
'have to do this again for some reason
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
'continue the page numbering
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).PageNumbers.RestartNumberingAtSection = False
'footers seems to work even if the page number is in the header
'Unlink even pages if the page setup is setup with Odd and Even Page setup
If ActiveDocument.Sections(currsec).PageSetup.OddAndEvenPagesHeaderFooter = True Then
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterEvenPages).LinkToPrevious = False
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterEvenPages).LinkToPrevious = False
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterEvenPages).PageNumbers.RestartNumberingAtSection = False
End If
'Lock the section break
ActiveDocument.Bookmarks.Add ("CurrSel") 'mark the insertion point
'go after the section break and highlight it
Selection.MoveLeft unit:=wdCharacter, Count:=1
'this will insert BEFORE THE SECTION BREAK in 2013
Selection.Range.ContentControls.Add (wdContentControlRichText)
'go after the section break and highlight it
Selection.MoveRight unit:=wdCharacter, Count:=2, Extend:=wdExtend
'the one that's just been inserted
With Selection.ContentControls(1)
.SetPlaceholderText , , text:=" "
.LockContentControl = True
.LockContents = True
.Title = "Locked Section Break"
End With
ActiveDocument.Bookmarks("CurrSel").Select
ActiveDocument.Bookmarks("CurrSel").Delete
'insert the Landscape autotext (this must have a locked section break after) only has the section break after
ActiveDocument.AttachedTemplate.AutoTextEntries(ATName).Insert _
Where:=Selection.Range, RichText:=True
'at this stage, if we have empty paramarkers, delete them
For i = 1 To 20
If Selection.Paragraphs(1).Range.text = Chr(13) And _
Selection.Paragraphs(1).ID <> ActiveDocument.Range.Paragraphs(ActiveDocument.Range.Paragraphs.Count).ID Then
'empty paragraph marker delete and go further up
If Selection.Paragraphs(1).Range.Next(unit:=wdParagraph, Count:=1).Information(wdWithInTable) = False Then
Selection.Paragraphs(1).Range.Delete
Else
Exit For
End If
Else
Exit For
End If
Next i
'update the fields in the new appendix header/footer
ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Fields.Update
ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).Range.Fields.Update
'we also need to update the header/footer in the rotated one (this has a shape, would be good if we could name it but this works too).
Dim oshp As Shape
For Each oshp In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.ShapeRange
'in case there are lines or other shapes in there.
On Error Resume Next
oshp.TextFrame.ContainingRange.Fields.Update
Err.Clear
On Error GoTo 0
Next oshp
'This is for a landscape that requires a different header/footer entry (i.e. different style reference field)
If AppDiffHead = True Then
'Find out whether we are in the Appendices
If ActiveDocument.Bookmarks.Exists("BM_SecBreakApp") = True Then
AppSec = ActiveDocument.Bookmarks("BM_SecBreakApp").Range.Information(wdActiveEndSectionNumber) + 1
'and if so insert the correct appendices header into the landscape header
If LandsSec > AppSec Then
Set rgAppHead = ActiveDocument.Sections(AppSec).Headers(wdHeaderFooterPrimary).Range.Bookmarks("BM_LsHeader").Range
'delete what's in there
rgAppHead.text = ""
'go to the first insertion point
rgAppHead.Collapse
ActiveDocument.AttachedTemplate.AutoTextEntries("AT_AppHeader").Insert _
'insert the new field
Where:=ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Bookmarks("BM_LsHeader").Range, _
RichText:=True
Set rgAppHead = Nothing
End If
End If
If ActiveDocument.Bookmarks.Exists("BM_LsHeader") Then
ActiveDocument.Bookmarks("BM_LsHeader").Delete 'make sure it's gone
End If
End If
'This is for a landscape without page number in the appendices
'Find out whether we are in the Appendices
If AppNoPgNo = True Then
'find out whether we are in the appendices
selInApp = IsSelectionInAppendix
If selInApp = True Then
'go into the header and footer of the new landscape page and delete the page number
For Each ofld In ActiveDocument.Sections(LandsSec).Footers(wdHeaderFooterPrimary).Range.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
For Each ofld In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
'For Portrait Landscape page
For Each ofld In ActiveDocument.Sections(LandsSec).Headers(wdHeaderFooterPrimary).Range.ShapeRange(1).TextFrame.TextRange.Fields
If ofld.Type = wdFieldPage Then
ofld.Result.Cells(1).Range.Delete
GoTo ContinueNoPgNumber 'found it
End If
Next ofld
End If
End If
ContinueNoPgNumber:
If TrackWasON = True Then
ActiveDocument.TrackRevisions = True
End If
If ActiveDocument.Bookmarks.Exists("BM_LandscapeHere") Then
ActiveDocument.Bookmarks("BM_LandscapeHere").Select
End If
Application.ScreenUpdating = True
End Sub
VBA - Headers & Footers
Defining a separate first page header and footer for the first section
With ActiveDocument.Sections(1)
.PageSetup.DifferentFirstPageHeaderFooter = True
.Footers(wdHeaderFooterIndex.wdHeaderFooterFirstPage).Range.InsertBefore "first page footer text"
End With
Linking/Unlinking Previous
The LinkToPrevious property applies to each type of header and each type of footer separately.
Setting this to True automatically inserts text into all headers (and footers)
Setting this to False does not automatically remove the text.
objHeaderFooter.LinkToPrevious = True | False
The following will unlink the current header from the previous header
iNoOfSections = ActiveDocument.Sections.Count
With Application.ActiveDocument.Sections(iNoOfSections).Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary)
.LinkToPrevious = False
.Range.Delete ''this line deletes everything from the header to make sure it is blank
End With
The following will unlink the current footer from the previous footer
iNoOfSections = ActiveDocument.Sections.Count
With Application.ActiveDocument.Sections(iNoOfSections).Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary)
.LinkToPrevious = False
.Range.Delete ''this line deletes everything from the header to make sure it is blank
End With
This creates Headers
Odd Page headers = Chapter, Page
Even Page headers = Page, Chapter
Public Sub MakeHeaders
Dim rng As Range
Dim sect As Section
Dim sChapter As String
For Each sect In ActiveDocument.Sections
'different odd and even page headers
sect.PageSetup.OddAndEvenPagesHeaderFooter = True
'unlink the headers and add a tab stop at right margin
With sect.Headers(wdHeaderFooterPrimary)
.LinkToprevious = False
.Range.ParagraphFormat.TabStops.ClearAll
.Range.ParagraphFormat.TabStops.Add _
sect.PageSetup.PageWidth - sect.PageSetup.RightMargin - sect.PageSetup.LeftMargin, _
wdTabAlignment.wdAlignTabRight
End With
'repeat for even page header
With sect.Headers(wdHeaderFooterEven)
.LinkToprevious = False
.Range.ParagraphFormat.TabStops.ClearAll
.Range.ParagraphFormat.TabStops.Add _
sect.PageSetup.PageWidth - sect.PageSetup.RightMargin - sect.PageSetup.LeftMargin, _
wdTabAlignment.wdAlignTabRight
End With
'get chapter X text from first paragraph in section
sChapter = sect.Range.Paragraphs(1).Range.Text
'trim paragraph mark if present
If Right(sChapter, 1) = vbCr Then
sChapter = Left(sChapter, Len(sChapter, 1)
End If
'do odd-page (primary header)
Set rng = sect.Headers(wdHeaderFooterPrimary).Range
rng.Text = sChapter & vbTab & "page "
rng.Collapse wdCollapseEnd
'insert page number
rng.Fields.Add rng, wdFieldType.wdFieldPage
'insert chapter number
Set rng = sect.Headers(wdHeaderFooterEvenPages).Range
rng.Collapse wdCollapseEnd
rng.InsertAfter vbTab & sChapter
Next sect
End Sub
VBA - Testing
Public Sub CreateDocument()
Dim oDocument As Word.Document
Dim oCellRange As Word.Range
On Error GoTo ErrorHandler
' ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = False
' Set oDocument = Application.Documents.Add
'
' oDocument.PageSetup.TopMargin = CentimetersToPoints(3.81)
' oDocument.PageSetup.BottomMargin = CentimetersToPoints(1.27)
'
' oDocument.ActiveWindow.View.Type = wdPrintView
Call Page_HeaderFooterInsert_Page1
'add/modify the page content
Set oCellRange = ActiveDocument.Sections(1).Range.Paragraphs(1).Range
oCellRange.InsertBreak (WdBreakType.wdSectionBreakNextPage)
Call Page_HeaderFooterInsert_Page2
'add/modify the page content
Set oCellRange = ActiveDocument.Content
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
oCellRange.InsertBreak (WdBreakType.wdSectionBreakNextPage)
Call Page_HeaderFooterInsert_Page3
'add/modify the page content
Set oCellRange = ActiveDocument.Content
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
oCellRange.Delete
Set oCellRange = ActiveDocument.Content
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
oCellRange.InsertBreak (WdBreakType.wdSectionBreakNextPage)
'add/modify the page content
Call Page_HeaderFooterInsert_Page4
'add/modify the page content
Set oCellRange = ActiveDocument.Content
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
oCellRange.Text = "Introduction"
ActiveDocument.ActiveWindow.View.Type = wdPrintView
' oRange.Style = "Header"
' oRange.InsertAfter "Boyd Consultants" & vbTab
' oRange.Collapse WdCollapseDirection.wdCollapseEnd
' ActiveDocument.Fields.Add Range:=oRange, _
' Type:=wdFieldEmpty, _
' Text:="FILENAME", _
' PreserveFormatting:=True
Exit Sub
ErrorHandler:
Call MsgBox(Err.Number & " - " & Err.Description)
End Sub
'****************************************************************************************
Public Sub Page_HeaderFooterInsert_Page1()
Const sPROCNAME As String = "Page_HeaderFooterInsert_Page1"
Dim oHeader As Word.HeaderFooter
Dim oHeaderRange As Word.Range
Dim oTable As Word.Table
Dim oCellRange As Word.Range
Dim oLogoShape As Word.Shape
On Error GoTo ErrorHandler
Set oHeader = ActiveDocument.Sections(1).Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
Set oHeaderRange = oHeader.Range
oHeaderRange.Paragraphs.Alignment = Word.WdParagraphAlignment.wdAlignParagraphRight
Set oTable = ActiveDocument.Tables.Add(Range:=oHeaderRange, _
NumRows:=1, _
NumColumns:=2, _
DefaultTableBehavior:=WdDefaultTableBehavior.wdWord8TableBehavior, _
AutoFitBehavior:=WdAutoFitBehavior.wdAutoFitWindow)
oTable.LeftPadding = CentimetersToPoints(0)
oTable.RightPadding = CentimetersToPoints(0)
oTable.Cell(1, 1).Range.Paragraphs.Alignment = wdAlignParagraphLeft
oTable.Cell(1, 1).Width = Application.CentimetersToPoints(3)
oTable.Cell(1, 2).Range.Paragraphs.Alignment = wdAlignParagraphLeft
oTable.Cell(1, 2).Width = Application.CentimetersToPoints(13.51)
oTable.Rows(1).SetHeight RowHeight:=Application.CentimetersToPoints(2.4), HeightRule:=wdRowHeightExactly
'add the orange bottom border
' oTable.Borders(wdBorderBottom).LineStyle = Word.WdLineStyle.wdLineStyleSingle
' oTable.Borders(wdBorderBottom).Color = RGB(240, 139, 29)
' oTable.Borders(wdBorderBottom).LineWidth = Word.WdLineWidth.wdLineWidth100pt
'add the logo to first cell
Set oCellRange = oTable.Cell(1, 1).Range
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseStart
Set oCellRange = Template_InsertCustomAutoText("AT_Logo", oCellRange)
'make the shape inline
Set oLogoShape = oCellRange.ShapeRange(1)
oLogoShape.WrapFormat.Type = wdWrapInline
'insert the embedded table
Set oCellRange = oTable.Cell(1, 2).Range
oCellRange.Collapse Direction:=WdCollapseDirection.wdCollapseStart
Set oTable = ActiveDocument.Tables.Add(Range:=oCellRange, _
NumRows:=2, _
NumColumns:=1, _
DefaultTableBehavior:=WdDefaultTableBehavior.wdWord8TableBehavior, _
AutoFitBehavior:=WdAutoFitBehavior.wdAutoFitWindow)
Exit Sub
ErrorHandler:
Call MsgBox(Err.Number & " - " & Err.Description)
End Sub
'****************************************************************************************
Public Sub Page_HeaderFooterInsert_Page2()
Const sPROCNAME As String = "Page_HeaderFooterInsert_Page2"
Dim oHeader As Word.HeaderFooter
Dim oHeaderRange As Word.Range
Dim oCellRange As Word.Range
Dim oLogoShape As Word.Shape
Dim oTable As Word.Table
On Error GoTo ErrorHandler
Set oHeader = ActiveDocument.Sections(2).Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
oHeader.LinkToPrevious = False
Set oHeaderRange = oHeader.Range
'inside the header, insert another table underneath
oHeaderRange.Collapse wdCollapseEnd
' oHeaderRange.Paragraphs.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
oHeaderRange.InsertParagraphAfter
oHeaderRange.Collapse wdCollapseEnd
Set oTable = oHeaderRange.Tables.Add(Range:=oHeaderRange, _
NumRows:=4, _
NumColumns:=1, _
DefaultTableBehavior:=WdDefaultTableBehavior.wdWord8TableBehavior, _
AutoFitBehavior:=WdAutoFitBehavior.wdAutoFitWindow)
oTable.Cell(1, 1).Range.Text = "three"
oTable.Cell(1, 1).Range.Style = "Heading 4" '"~ProjectName"
oTable.Cell(2, 1).Range.Text = "four"
oTable.Cell(2, 1).Range.Style = "Heading 5" '"~ReportTitle"
oTable.Cell(3, 1).Range.Text = "five"
oTable.Cell(3, 1).Range.Style = "Heading 6" '"~PropertyAddress"
Exit Sub
ErrorHandler:
Call MsgBox(Err.Number & " - " & Err.Description)
' Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub
'****************************************************************************************
Public Sub Page_HeaderFooterInsert_Page3()
Const sPROCNAME As String = "Page_HeaderFooterInsert_Page3"
Dim oHeader As Word.HeaderFooter
Dim oHeaderRange As Word.Range
Dim oTable As Word.Table
On Error GoTo ErrorHandler
Set oHeader = ActiveDocument.Sections(3).Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
oHeader.LinkToPrevious = False
Set oHeaderRange = oHeader.Range
'modify the embedded table
Set oTable = oHeaderRange.Tables(1).Tables(1)
oTable.Cell(1, 1).Range.Text = "one"
oTable.Cell(1, 1).Range.Style = "Heading 3"
oTable.Cell(1, 1).Range.Paragraphs.Alignment = wdAlignParagraphRight
oTable.Cell(2, 1).Range.Text = "two"
oTable.Cell(2, 1).Range.Style = "Heading 4"
oTable.Cell(2, 1).Range.Paragraphs.Alignment = wdAlignParagraphRight
'inside the header, remove the second table
Set oTable = oHeaderRange.Tables(2)
oTable.Delete
oHeaderRange.Collapse wdCollapseEnd
oHeaderRange.Delete
Exit Sub
ErrorHandler:
Call MsgBox(Err.Number & " - " & Err.Description)
End Sub
'****************************************************************************************
Public Sub Page_HeaderFooterInsert_Page4()
Const sPROCNAME As String = "Page_HeaderFooterInsert_Page4"
Dim oFooter As Word.HeaderFooter
Dim oFooterRange As Word.Range
Dim oTable As Word.Table
On Error GoTo ErrorHandler
Set oFooter = ActiveDocument.Sections(4).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary)
oFooter.LinkToPrevious = False
Set oFooterRange = oFooter.Range
'inside the footer, add the page number
oFooterRange.Text = "footer"
Exit Sub
ErrorHandler:
Call MsgBox(Err.Number & " - " & Err.Description)
End Sub
'****************************************************************************************
Attribute VB_Name = "modAppendixDivider"
Option Explicit
Public Sub InsertAppendixDivider()
Dim oRange As Word.Range
Dim oRange2 As Word.Range
Dim oBMRange As Word.Range
Dim oFormField As Word.FormField
Set oRange = Selection.Range
oRange.Paragraphs.Format.Style = "Heading 1"
Set oFormField = Selection.FormFields.Add(Range:=oRange, _
Type:=WdFieldType.wdFieldFormTextInput)
oFormField.Result = "<Insert Appendix Heading>"
Set oBMRange = oFormField.Range
'oBMRange.Select
ActiveDocument.Bookmarks.Add name:="BM_FirstAppHeading", Range:=oBMRange
Set oRange = oBMRange.Duplicate
oRange.Collapse wdCollapseEnd
oRange.Select
oRange.InsertParagraph
oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
'oRange.Select
'add the bookmark including the paragraph mark
'oBMRange.Select
oBMRange.End = oBMRange.End + 1
oBMRange.Select
ActiveDocument.Bookmarks.Add name:="BM_AppHeading", Range:=oBMRange
oRange.Paragraphs.Format.Style = "Heading 2"
Set oFormField = Selection.FormFields.Add(Range:=oRange, _
Type:=WdFieldType.wdFieldFormTextInput)
oFormField.Result = "<Insert description text if required>"
Set oRange = oFormField.Range
oRange.Collapse wdCollapseEnd
oRange.InsertParagraph
oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
oRange.InsertBreak (WdBreakType.wdPageBreak)
oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
End Sub
'WITH TABLE
'Public Sub InsertAppendixDivider()
'Dim oRange As Word.Range
'Dim oBMRange As Word.Range
'Dim oFormField As Word.FormField
'
' Set oRange = Selection.Range
'
' Set oTable = ActiveDocument.Tables.Add(Range:=oRange, _
' NumRows:=1, _
' NumColumns:=1, _
' DefaultTableBehavior:=WdDefaultTableBehavior.wdWord8TableBehavior, _
' AutoFitBehavior:=WdAutoFitBehavior.wdAutoFitWindow)
'
' Set oRange = oTable.Cell(1, 1).Range
' 'oRange.Select
'
' 'modify the range to the contents of the cell, not the whole cell
' oRange.End = oRange.End - 1
'
' oRange.Paragraphs.Format.Style = "~AppHead1"
' Set oFormField = Selection.FormFields.Add(Range:=oRange, _
' Type:=WdFieldType.wdFieldFormTextInput)
' oFormField.Result = "<Insert Appendix Heading>"
'
' Set oBMRange = oFormField.Range
' ActiveDocument.Bookmarks.Add name:="BM_FirstAppHeading", Range:=oBMRange
'
' Set oRange = oTable.Cell(1, 1).Range
'
' oRange.End = oRange.End - 1
' oRange.Collapse wdCollapseEnd
' oRange.InsertParagraph
' oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
'
' 'add the bookmark including the paragraph mark
' oBMRange.End = oBMRange.End + 1
' ActiveDocument.Bookmarks.Add name:="BM_AppHeading", Range:=oBMRange
'
'
' oRange.Paragraphs.Format.Style = "~TableTextLeft"
' Set oFormField = Selection.FormFields.Add(Range:=oRange, _
' Type:=WdFieldType.wdFieldFormTextInput)
' oFormField.Result = "<Insert description text if required>"
'
' Set oRange = oTable.Range
' oRange.Collapse wdCollapseEnd
'
' oRange.InsertParagraph
' oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
'
' oRange.InsertBreak (WdBreakType.wdPageBreak)
' oRange.Move Unit:=WdUnits.wdParagraph, Count:=1
'
'End Sub
© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited TopPrev