none
TOC Help RRS feed

  • Question

  • I have the following macros that creates a Table of Contents. Is there a way to do the Following?

    It creates a bookmarker at a set location in the document and then creates the table of contents. What I want it to do is when it is creating the TOC to stop at the bookmark and not use anything past the bookmark when making the TOC.

    Sub CreateTableOfContentUsingHeadrers()
        frmTOC3.Show
    End Sub


    This is what is in frmTOC3:

    Private Sub CommandButton1_Click()
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "ATTACHMENTS"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .Style = "Heading 1"
    End With
    Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    With ActiveDocument.Bookmarks
        .Add Range:=Selection.Range, Name:="bkatt"
        .DefaultSorting = wdSortByName
        .ShowHidden = False
    End With

    If CheckBox1.Value = True Then
        With ActiveDocument.Styles("TOC 1")
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
        End With
        With ActiveDocument.Styles("TOC 1").ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel1
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
        End With
        ActiveDocument.Styles("TOC 1").NoSpaceBetweenParagraphsOfSameStyle = False
        ActiveDocument.Styles("TOC 1").ParagraphFormat.TabStops.ClearAll
        ActiveDocument.Styles("TOC 1").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(0.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        ActiveDocument.Styles("TOC 1").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(6.89), Alignment:=wdAlignTabRight, Leader:= _
            wdTabLeaderSpaces
        With ActiveDocument.Styles("TOC 1")
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
        End With
        With ActiveDocument
            .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
                True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
                LowerHeadingLevel:=1, IncludePageNumbers:=True, AddedStyles:="", _
                UseHyperlinks:=False, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
                True, UseFields:=True
            .TablesOfContents(1).TabLeader = wdTabLeaderDots
            .TablesOfContents.Format = wdIndexIndent
        End With
        Call RemoveUnderlinesinTOC

    ElseIf CheckBox2.Value = True Then
        With ActiveDocument.Styles("TOC 2")
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
        End With
        With ActiveDocument.Styles("TOC 2").ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel2
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
        End With
        ActiveDocument.Styles("TOC 2").NoSpaceBetweenParagraphsOfSameStyle = True
        ActiveDocument.Styles("TOC 2").ParagraphFormat.TabStops.ClearAll
        ActiveDocument.Styles("TOC 2").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(0.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        ActiveDocument.Styles("TOC 2").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(6.89), Alignment:=wdAlignTabRight, Leader:= _
            wdTabLeaderSpaces
        With ActiveDocument
            .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
                True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
                LowerHeadingLevel:=2, IncludePageNumbers:=True, AddedStyles:="", _
                UseHyperlinks:=False, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
                True, UseFields:=True
            .TablesOfContents(1).TabLeader = wdTabLeaderDots
            .TablesOfContents.Format = wdIndexIndent
        End With
        Call RemoveUnderlinesinTOC

    ElseIf CheckBox3.Value = True Then
        With ActiveDocument.Styles("TOC 3")
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
        End With
        With ActiveDocument.Styles("TOC 3").ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel3
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
        End With
        ActiveDocument.Styles("TOC 3").NoSpaceBetweenParagraphsOfSameStyle = True
        ActiveDocument.Styles("TOC 3").ParagraphFormat.TabStops.ClearAll
        ActiveDocument.Styles("TOC 3").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(0.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        ActiveDocument.Styles("TOC 3").ParagraphFormat.TabStops.Add Position:= _
            InchesToPoints(6.89), Alignment:=wdAlignTabRight, Leader:= _
            wdTabLeaderSpaces
        With ActiveDocument
            .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _
                True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
                LowerHeadingLevel:=3, IncludePageNumbers:=True, AddedStyles:="", _
                UseHyperlinks:=False, HidePageNumbersInWeb:=True, UseOutlineLevels:= _
                True, UseFields:=True
            .TablesOfContents(1).TabLeader = wdTabLeaderDots
            .TablesOfContents.Format = wdIndexIndent
        End With
    Call RemoveUnderlinesinTOC
    End If
    CheckBox1.Value = False
    CheckBox2.Value = False
    CheckBox3.Value = False
    Me.Hide
    End Sub

    Friday, August 10, 2012 2:17 AM

Answers

  • FWIW, I suspect your code could be reduced to:

    Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Dim BmRng As Range, i As Long, j As Long
    With ActiveDocument
      With .Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ""
          .Style = "Heading 1"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindContinue
          .Format = True
          .MatchCase = True
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Execute
        End With
        Set BmRng = .Duplicate
        With .Find
          .Text = "ATTACHMENTS"
          .Style = "Heading 1"
          .Execute
        End With
        BmRng.End = .Duplicate.Start - 1
      End With
      .Bookmarks.Add Name:="TOCRng", Range:=BmRng
      For i = 1 To 3
        If Me.Controls("CheckBox" & i).Value = True Then
          j = i
          With .Styles("TOC " & i)
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
            .NoSpaceBetweenParagraphsOfSameStyle = False
            With .ParagraphFormat
              .LeftIndent = InchesToPoints(0.5)
              .RightIndent = InchesToPoints(0.5)
              .SpaceBefore = 6
              .SpaceBeforeAuto = False
              .SpaceAfter = 6
              .SpaceAfterAuto = False
              .LineSpacingRule = wdLineSpaceSingle
              .Alignment = wdAlignParagraphLeft
              .WidowControl = False
              .KeepWithNext = False
              .KeepTogether = False
              .PageBreakBefore = False
              .NoLineNumber = False
              .Hyphenation = False
              .FirstLineIndent = InchesToPoints(-0.5)
              .OutlineLevel = wdOutlineLevel1
              .CharacterUnitLeftIndent = 0
              .CharacterUnitRightIndent = 0
              .CharacterUnitFirstLineIndent = 0
              .LineUnitBefore = 0
              .LineUnitAfter = 0
              With .TabStops
                .ClearAll
                .Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabLeft, _
                  Leader:=wdTabLeaderSpaces
                .Add Position:=InchesToPoints(6.89), Alignment:=wdAlignTabRight, _
                  Leader:=wdTabLeaderSpaces
              End With
          End With
        End With
        Me.Controls("CheckBox" & i).Value = False
      Next
      .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
        Text:="TOC \o " & Chr(34) & "1-" & j & Chr(34) & " \f \z \u \b ""TOCRng""", _
        Preserveformatting:=False
      Call RemoveUnderlinesinTOC
    End With
    Application.ScreenUpdating = True
    Me.Hide
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by fuzzhead58 Monday, August 13, 2012 7:47 PM
    Sunday, August 12, 2012 3:40 AM

All replies

  • To use a bookmark with a TOC, you need to bookmark the entire range the TOC is to span, then reference the bookmark in the TOC field code.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Friday, August 10, 2012 3:59 AM
  • How would I set my bookmark to cover the entire range of the TOC?

    I know my procedures all start out with my Styles (Heading 1) and the number 1.0. Then I want to go to the end of the text in the procedure which will end in Styles (Heading 1), some number and the work "ATTACHMENTS".

    Friday, August 10, 2012 8:28 PM
  • The start the first 'Heading 1' Style paragraph defines where your bookmarked range would start. The last character before the 'Attachments' heading/Section defines where your bookmarked range would end. There are many ways you could identify where these locations are. Depending on what you already have coded, you may already have variables that you can use to identify them; otherwise you could use Word's Find function.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Friday, August 10, 2012 9:53 PM
  • I am not sure how to write this in VB. I would start out with the following to get me to Heading 1. But then how would I make my macro set my bookmarker 'bkatt'?

    Selection.GoTo What = wdGotoHeading, Which = wdGoTOFirst, Count=1,Name=""

    Selection. Find.ClearFormatting

    With Selection.Find

          .Text = "1.0"

          .Replacement.Text = ""

          . Forward = True

          .Wrap = wdFindContinue

    End With

    

    Friday, August 10, 2012 10:37 PM
  • You could use code like:

    Sub Demo()
    Application.ScreenUpdating = False
    Dim RngDoc As Range, BmRng As Range
    Set RngDoc = ActiveDocument.Range
    With RngDoc
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Style = "Heading 1"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
      End With
      Set BmRng = .Duplicate
      With .Find
        .Text = "ATTACHMENTS"
        .Style = "Heading 1"
        .Execute
      End With
      BmRng.End = .Duplicate.Start - 1
      .Bookmarks.Add Name:="bkatt", Range:=BmRng
    End With
    Application.ScreenUpdating = True
    End Sub

    Note that I've assumed your "ATTACHMENTS" heading also uses the 'Heading 1' Style. If it doesn't, you'll need to supply the correct Style name.


    Cheers
    Paul Edstein
    [MS MVP - Word]


    • Edited by macropodMVP Saturday, August 11, 2012 10:34 PM
    Friday, August 10, 2012 11:17 PM
  • Thanks for your help. I'll give it a try tommorrow morning at work and let you know what happens.

    Friday, August 10, 2012 11:23 PM
  • That worked. Now based on my macro posted at the begining, how do I tell the macro to use only the information inside the bookmarks?
    Saturday, August 11, 2012 2:50 PM
  • Try the following. Note that I've cleaned up your code somewhat.

    Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Dim BmRng As Range
    With ActiveDocument
      With .Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ""
          .Style = "Heading 1"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindContinue
          .Format = True
          .MatchCase = True
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Execute
        End With
        Set BmRng = .Duplicate
        With .Find
          .Text = "ATTACHMENTS"
          .Style = "Heading 1"
          .Execute
        End With
        BmRng.End = .Duplicate.Start - 1
      End With
      .Bookmarks.Add Name:="TOCRng", Range:=BmRng
      If CheckBox1.Value = True Then
        With .Styles("TOC 1")
          .AutomaticallyUpdate = True
          .BaseStyle = "Normal"
          .NextParagraphStyle = "Normal"
          .NoSpaceBetweenParagraphsOfSameStyle = False
          With .ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel1
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
            With .TabStops
              .ClearAll
              .Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabLeft, _
                Leader:=wdTabLeaderSpaces
              .Add Position:=InchesToPoints(6.89), Alignment:=wdAlignTabRight, _
                Leader:=wdTabLeaderSpaces
            End With
          End With
        End With
        .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
          Text:="TOC \o ""1-1"" \f \z \u \b ""TOCRng""", Preserveformatting:=False
        Call RemoveUnderlinesinTOC
      ElseIf CheckBox2.Value = True Then
        With .Styles("TOC 2")
          .AutomaticallyUpdate = True
          .BaseStyle = "Normal"
          .NextParagraphStyle = "Normal"
          .NoSpaceBetweenParagraphsOfSameStyle = True
          With .ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel2
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
            With .TabStops
              .ClearAll
              .Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabLeft, _
                Leader:=wdTabLeaderSpaces
              .Add Position:=InchesToPoints(6.89), Alignment:=wdAlignTabRight, _
                Leader:=wdTabLeaderSpaces
            End With
          End With
        .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
          Text:="TOC \o ""1-2"" \f \z \u \b ""TOCRng""", Preserveformatting:=False
        Call RemoveUnderlinesinTOC
      ElseIf CheckBox3.Value = True Then
        With .Styles("TOC 3")
          .AutomaticallyUpdate = True
          .BaseStyle = "Normal"
          .NextParagraphStyle = "Normal"
          .NoSpaceBetweenParagraphsOfSameStyle = True
          With .ParagraphFormat
            .LeftIndent = InchesToPoints(0.5)
            .RightIndent = InchesToPoints(0.5)
            .SpaceBefore = 6
            .SpaceBeforeAuto = False
            .SpaceAfter = 6
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
            .NoLineNumber = False
            .Hyphenation = False
            .FirstLineIndent = InchesToPoints(-0.5)
            .OutlineLevel = wdOutlineLevel3
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
          End With
            With .TabStops
              .ClearAll
              .Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabLeft, _
                Leader:=wdTabLeaderSpaces
              .Add Position:=InchesToPoints(6.89), Alignment:=wdAlignTabRight, _
                Leader:=wdTabLeaderSpaces
            End With
          End With
        .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
          Text:="TOC \o ""1-3"" \f \z \u \b ""TOCRng""", Preserveformatting:=False
        Call RemoveUnderlinesinTOC
      End If
    End With
    Application.ScreenUpdating = True
    CheckBox1.Value = False
    CheckBox2.Value = False
    CheckBox3.Value = False
    Me.Hide
    End Sub

    I note that you have calls to a procedure named 'RemoveUnderlinesinTOC'. Please note that anything you do to modify the appearance of the text in a TOC, other than via Style formatting, is doomed to failure. That's because, as soon as anything happens to cause the TOC to update (eg printing the document), the original formatting will be restored.


    Cheers
    Paul Edstein
    [MS MVP - Word]



    • Edited by macropodMVP Sunday, August 12, 2012 3:42 AM Fixed code line wraps
    Saturday, August 11, 2012 11:14 PM
  • FWIW, I suspect your code could be reduced to:

    Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Dim BmRng As Range, i As Long, j As Long
    With ActiveDocument
      With .Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ""
          .Style = "Heading 1"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindContinue
          .Format = True
          .MatchCase = True
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Execute
        End With
        Set BmRng = .Duplicate
        With .Find
          .Text = "ATTACHMENTS"
          .Style = "Heading 1"
          .Execute
        End With
        BmRng.End = .Duplicate.Start - 1
      End With
      .Bookmarks.Add Name:="TOCRng", Range:=BmRng
      For i = 1 To 3
        If Me.Controls("CheckBox" & i).Value = True Then
          j = i
          With .Styles("TOC " & i)
            .AutomaticallyUpdate = True
            .BaseStyle = "Normal"
            .NextParagraphStyle = "Normal"
            .NoSpaceBetweenParagraphsOfSameStyle = False
            With .ParagraphFormat
              .LeftIndent = InchesToPoints(0.5)
              .RightIndent = InchesToPoints(0.5)
              .SpaceBefore = 6
              .SpaceBeforeAuto = False
              .SpaceAfter = 6
              .SpaceAfterAuto = False
              .LineSpacingRule = wdLineSpaceSingle
              .Alignment = wdAlignParagraphLeft
              .WidowControl = False
              .KeepWithNext = False
              .KeepTogether = False
              .PageBreakBefore = False
              .NoLineNumber = False
              .Hyphenation = False
              .FirstLineIndent = InchesToPoints(-0.5)
              .OutlineLevel = wdOutlineLevel1
              .CharacterUnitLeftIndent = 0
              .CharacterUnitRightIndent = 0
              .CharacterUnitFirstLineIndent = 0
              .LineUnitBefore = 0
              .LineUnitAfter = 0
              With .TabStops
                .ClearAll
                .Add Position:=InchesToPoints(0.5), Alignment:=wdAlignTabLeft, _
                  Leader:=wdTabLeaderSpaces
                .Add Position:=InchesToPoints(6.89), Alignment:=wdAlignTabRight, _
                  Leader:=wdTabLeaderSpaces
              End With
          End With
        End With
        Me.Controls("CheckBox" & i).Value = False
      Next
      .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
        Text:="TOC \o " & Chr(34) & "1-" & j & Chr(34) & " \f \z \u \b ""TOCRng""", _
        Preserveformatting:=False
      Call RemoveUnderlinesinTOC
    End With
    Application.ScreenUpdating = True
    Me.Hide
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by fuzzhead58 Monday, August 13, 2012 7:47 PM
    Sunday, August 12, 2012 3:40 AM
  • This worked great! Thank yo for all your help.....

    Larry

    Monday, August 13, 2012 7:47 PM