Macro to collapse outline headings above the currrent cursor posit

[Steve]

Scenario: I have the cursor on some text at level 5 . I want to keep this
text visible but I want to see all document text above that text collapsed
into headings and subheadings. This way I can get a better idea of the
context of the text at level 5.

Note: I can do it manually of course, but a macro (if anyone has one) would
really speed up my work.
I have tried using the document map but it really is only marginally faster
than manually doing it in Outline view

 

[Stefan Blom]

The following simple macro can be used to collapse text:

Sub CollapseHeadingLevels()
Dim CurrentView As Long
Dim HeadingLevel As Long
CurrentView = ActiveWindow.View.Type 'Current view
ActiveWindow.View.Type = 3 'Print Layout view
HeadingLevel = Selection.Paragraphs(1).OutlineLevel

If HeadingLevel < 1 Or HeadingLevel > 9 Then
ActiveWindow.View.Type = CurrentView
Exit Sub
End If

With ActiveWindow.View
.Type = 2 'Outline view
.ShowHeading HeadingLevel
End With
End Sub

--
Stefan Blom
Microsoft Word MVP


in message
news:[email protected]...

 

[Steve]

Thanks - I do have a macro that does the basic collapse already but was
hoping someone might have one that goes a step further to just collapse the
headings above the cursor point. It may not be possible?

 

[Stefan Blom]

Are you saying that, if the insertion point is (say) in a Heading 5
paragraph, you want to display Headings 1-5 above that Heading 5, but
display all text below it? If so, the following macro should work:

Sub test()
Dim w As Range
Dim CurrentView As Long
Dim HeadingLevel As Long

CurrentView = ActiveWindow.View.Type 'Current view
ActiveWindow.View.Type = 3 'Print Layout view
HeadingLevel = Selection.Paragraphs(1).OutlineLevel

If HeadingLevel < 1 Or HeadingLevel > 9 Then
ActiveWindow.View.Type = CurrentView
Exit Sub
End If

Set w = ActiveDocument.Range(Start:=Selection.Range.Start, _
End:=ActiveDocument.Content.End)

ActiveWindow.View.Type = 2

ActiveWindow.View.ShowHeading HeadingLevel

For i = 1 To 9
ActiveWindow.View.ExpandOutline w
Next i
End Sub

--
Stefan Blom
Microsoft Word MVP


in message