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
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrev