Skip to content

Instantly share code, notes, and snippets.

@githubyouser

githubyouser/TOCforCDL.bas

Created October 27, 2023 22:15
Download ZIP

Revisions

  1. githubyouser created this gist Oct 27, 2023.
    105 changes: 105 additions & 0 deletions TOCforCDL.bas
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,105 @@
    Sub CreateTOCforCDL()

    'Add page breaks to make all chapter titles start on an odd page number
    Dim rng As Range
    Dim pgNum As Integer
    Set rng = ActiveDocument.Range
    With rng.Find
    .style = ActiveDocument.Styles("Heading 1")
    .Forward = True
    .Wrap = wdFindStop

    Do While .Execute
    pgNum = rng.Information(wdActiveEndPageNumber)
    If pgNum Mod 2 = 0 Then
    rng.Collapse Direction:=wdCollapseStart
    rng.InsertBreak Type:=wdPageBreak
    End If
    Loop
    End With

    ' Create a dictionary to store the Heading 2 text and page numbers
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    '----------CREATE A STYLE FOR THE TOC-------

    'https://narkive.com/EWve4CSW:2.570.423
    Dim findStyle As style, customStyle As style
    Dim bFound As Boolean
    Dim strcustomStyle As String

    'Check for the style
    strcustomStyle = "SGC custom TOC"
    For Each findStyle In ActiveDocument.Styles
    If LCase(findStyle.NameLocal) = LCase(strcustomStyle) Then
    bFound = True
    Set customStyle = ActiveDocument.Styles(strcustomStyle)
    Exit For
    End If
    Next findStyle

    'If the style doesn't exist, create it
    If Not bFound Then
    Set customStyle = ActiveDocument.Styles.Add(Name:=strcustomStyle, _
    Type:=wdStyleTypeParagraphOnly)
    customStyle.BaseStyle = "Normal"
    With customStyle
    .NoSpaceBetweenParagraphsOfSameStyle = True
    .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
    .ParagraphFormat.LineSpacing = 14
    .ParagraphFormat.TabStops.Add Position:=InchesToPoints(3.8), Alignment:=wdAlignTabLeft
    .ParagraphFormat.TabStops.Add Position:=InchesToPoints(5), Alignment:=wdAlignTabLeft
    End With
    End If
    '--------------------------------------------

    ' Loop through each paragraph in the document
    Dim para As Paragraph
    For Each para In ActiveDocument.Paragraphs
    ' If the style is "Heading 2", add the text and page number to the dictionary
    If para.Range.style = "Heading 2" Then
    Dim text As String

    'Remove the linebreak
    text = Replace(para.Range.text, Chr(13), "")
    'Trim trailing space
    text = RTrim(text)

    ' Check if the heading already exists in the dictionary
    If dict.Exists(text) Then
    ' If it does, append the new page number to the existing page numbers
    dict(text) = dict(text) & vbTab & para.Range.Information(wdActiveEndAdjustedPageNumber)
    Else
    ' If it doesn't, add it to the dictionary with the page number
    dict.Add text, para.Range.Information(wdActiveEndAdjustedPageNumber)
    End If
    End If
    Next para

    'Page break at the end before we add the TOC
    Set endRange = ActiveDocument.Content
    endRange.Collapse Direction:=wdCollapseEnd
    With endRange
    .InsertBreak Type:=wdPageBreak
    End With

    ' Loop through each item in the dictionary and add it to the new document
    Dim key As Variant
    For Each key In dict.Keys

    Dim newRange As Range
    Set newRange = ActiveDocument.Content
    newRange.Collapse Direction:=wdCollapseEnd

    'Insert the TOC contents from the dictionary
    newRange.InsertAfter key & vbTab & dict(key) & vbCrLf

    'Style it
    newRange.style = customStyle
    Next key

    Selection.EndKey Unit:=wdStory
    MsgBox "Created a custom TOC at the END of this document!"

    End Sub