CODEWITHSUNDEEP
vbams-word
s2016
s2016

Reputation: 63

How to Read MS Word DOCX using its Outline into subdocuments (using VBA)?

I am trying to create multiple Word subdocuments from each section of my master-DOCX using Word-VBA.

MAIN DOCX Print Layout

enter image description here

MAIN DOCX Outline View-ALL Levels

enter image description here

MAIN DOCX Outline View-FOUR Levels

enter image description here

Example output would be:

EXAMPLE OUTPUT IS HERE

The subdocuments(DOCX's) get the name similar to the above (including the name of the style used in the first word of the section). The content contains some rich text e.g. some words may be bolded, italicised etc.

Would appreciate comments as to how to approach this with Word-VBA.

The following code is at the heart of the problem. It uses the Word Edit/Find/Goto/Heading command to increment through the Outline Levels. However I can't find a way to select all the text between Outline Levels when multiple paragraph markers are involved. I want to copy this rich text out to one of the subdocuments.

Sub Goto_Outline_Levels()
    ActiveWindow.ActivePane.View.Type = wdPageView
    Selection.HomeKey Unit:=wdStory
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
    Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
End Sub

Upvotes: 0

Views: 345

Answers (1)

Cindy Meister
Cindy Meister

Reputation: 25673

The trick to something like this is to use Range objects. Unlike a selection, your code can work with multiple Ranges. So you can save the starting point of a heading section in one Range, the end point (start of the next heading section) in another Range and the content for a sub-document in yet a third Range.

Sub CreateSubDocsPerHeadingStyle()
    Dim doc As word.Document
    Dim rngStart As word.Range
    Dim rngEnd As word.Range
    Dim rngSubDoc As word.Range

    Set doc = ActiveDocument
    Selection.HomeKey Unit:=wdStory
    Do
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
        Set rngStart = Selection.Range
        Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
        Set rngEnd = Selection.Range
        rngEnd.Collapse wdCollapseStart
        If rngEnd.End = rngStart.Start Then
            'At the last heading section
            rngEnd.End = doc.content.End
        End If
        Set rngSubDoc = doc.Range(rngStart.Start, rngEnd.End)
        rngSubDoc.Select
        rngSubDoc.Subdocuments.AddFromRange rngSubDoc
        rngEnd.Select
    Loop While rngEnd.End <> doc.content.End
End Sub

Upvotes: 1

Related Questions