Creating a master document from code

[Ogier]

Using VBA I have been trying to create a master document with some
subdocuments in it.
A shortened version of my code appears below.
When I run it, the result looks fine but for one essential feature: Viewing
in "Outline view", "Show document" (I think it is called) the subdocuments
appear nested (third inside second and second inside first) instead of
appearing sequentially.

What am I doing wrong?

Best wishes
Holger Nielsen

Option Explicit

Dim intSectionNo As Integer
Dim strSectionNo As String

Sub CreateMasterDocument()
Dim SecNum As Integer
Dim sect As Section
Dim rng As Word.Range
' Initialization
intSectionNo = 1
strSectionNo = CStr(intSectionNo)
Application.ScreenUpdating = False
System.Cursor = wdCursorWait
' Clear document for previous test contents
ClearDocument
Set rng = ActiveDocument.Content
InsertNewSection rng, "This is the master document", False
InsertNormalText rng, "A line of text in the master document"
InsertNormalText rng, "Another line of text in the master document"

InsertNewSection rng, "First Subdocument", True
InsertNormalText rng, "A line of text in the first subdocument"
InsertNormalText rng, "Another line of text in the first subdocument"

InsertNewSection rng, "Second Subdocument", True
InsertNormalText rng, "A line of text in the second subdocument"
InsertNormalText rng, "Another line of text in the second subdocument"

InsertNewSection rng, "Third Subdocument", True
InsertNormalText rng, "A single line of text"

InsertNewSection rng, "This is the last page of the master document",
False
InsertNormalText rng, "A line of text on the last page of the master
document"
InsertNormalText rng, "Another line of text on the last page of the
master document"
ActiveDocument.SaveAs FileName:="Y:\Mastertest.docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="",
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False,
SaveFormsData _
:=False, SaveAsAOCELetter:=False
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
End Sub

Sub ClearDocument()
Dim sect As Section
Dim hdft As HeaderFooter
With ActiveDocument
' Clear headers and footers
For Each sect In .Sections
For Each hdft In sect.Headers
hdft.Range.Delete
Next
For Each hdft In sect.Footers
hdft.Range.Delete
Next
Next
' Clear document
.Content.Delete
End With
End Sub

Sub InsertChapterTitle(ByRef rng As Word.Range, strTitle As String,
MakeSubDocument As Boolean)
rng.Text = strTitle & vbCr
rng.Style = ActiveDocument.Styles("Overskrift 1") ' Heading 1

If MakeSubDocument Then
ActiveDocument.Subdocuments.AddFromRange Range:=rng
End If

rng.Collapse Direction:=wdCollapseEnd
End Sub

Sub InsertNormalText(ByRef rng As Word.Range, Text As String)
rng.Text = Text & vbCr
rng.Style = ActiveDocument.Styles("Normal")
rng.Collapse Direction:=wdCollapseEnd
End Sub

Sub InsertNewHeader(Caption As String)
Dim rng As Word.Range
Dim fld As Word.Field
With ActiveDocument.Sections(intSectionNo)
If intSectionNo <> 1 Then
With .Headers(wdHeaderFooterPrimary)
.LinkToPrevious = False
Set rng = .Range.Duplicate
rng.Text = "Header text" & vbTab & "Center of line" & vbTab
& "Side "
rng.Collapse wdCollapseEnd
' Use SEQ-field to insert page number
Set fld = rng.Fields.Add(Range:=rng, Type:=wdFieldEmpty, _
Text:="PAGE \* Arabic ", PreserveFormatting:=False)
Set rng = fld.Result
With rng
.Collapse Direction:=wdCollapseEnd
.MoveStart Unit:=wdCharacter, Count:=1
.Text = Chr(11) & Caption & " Section " & strSectionNo
End With
.Range.End = rng.End
.Range.Font.Size = 9
End With
End If
End With
End Sub

Sub InsertNewFooter()
Dim rng As Word.Range
With ActiveDocument.Sections(intSectionNo)
With .Footers(wdHeaderFooterPrimary)
If intSectionNo > 1 Then
.LinkToPrevious = False
End If
Set rng = .Range.Duplicate
rng.Text = "Footer text. Section " & strSectionNo
rng.Collapse Direction:=wdCollapseEnd
.Range.End = rng.End
.Range.Font.Size = 9
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
End Sub

Sub InsertNewSection(ByRef rng As Word.Range, ChapterTitle As String,
MakeSubDocument As Boolean)
rng.InsertBreak Type:=wdSectionBreakNextPage
intSectionNo = intSectionNo + 1
strSectionNo = CStr(intSectionNo)
InsertNewHeader ChapterTitle
InsertNewFooter
InsertChapterTitle rng, ChapterTitle, MakeSubDocument
End Sub