Macro for enyone and everyone TOC based on FN

RRB · #1 02-11-2024, 05:53 AM

The challenge: To create a TOC exclusively based on the FN area for a certain chapter of a book in Word.

The problem:
Due to MSoft's extreme AntiFooteNoteIsm, it is not allowing Word to pick up TC fields in the FN area. We need to go about this manually.

The macro builds the TOC based on text formatted with char style MyStyle. Builds the text of the toc and then calculates how this will affect page numbering and then inserts the results at the current location. The macro only collected the text string formatted with this style till it hits a section break which designates the end of the chapter.

So we will have to build two TOC, one for the main text area and another for the FN area, and then manually merge them

I imagine this macro can be modified a lot to do a more efficient job. If anybody does do anything I would appreciate them posting it here.

I didn't write this of course only paid a friend of mine to do it,

Enjoy!

Susan

PS Since I paid for this and this friend takes money for every and any keystroke he makes for me I would appreciate hearing criticism if you think he went about it correctly. Thank you -Susan
-------------------------------------------------------------->
Sub MakeTOCBasedOnFN()
CreateTableContentsForCurrentSection "myStyle"
End Sub

Sub CreateTableContentsForCurrentSection(styleName As String)

Dim curSec As Section
Set curSec = GetCurrrentSection

Dim texts As New Collection

ScanSectionFootNotes curSec, texts, styleName
InsertTableOfContents texts

End Sub

Sub InsertTableOfContents(texts As Collection)

Dim paras As New Collection
Dim rng As Range
Dim i As Integer
For i = 1 To texts.Count
Set rng = texts(i)
Selection.TypeText rng.text
paras.Add Selection.Range.Duplicate

Selection.TypeText vbCr
Next

Dim paraRng As Range
For i = 1 To paras.Count
Set rng = texts(i)
Set paraRng = paras(i)
paraRng.text = " " & rng.Information(wdActiveEndAdjustedPageNumber)
Next

End Sub

Sub ScanSectionFootNotes(sec As Section, texts As Collection, styleName As String)

Dim orginalSelection As Range
Set orginalSelection = Selection.Range.Duplicate

Dim fn As Footnote
Dim findRenge As Range
Dim i As Integer
For i = 1 To sec.Range.Footnotes.Count
Set fn = sec.Range.Footnotes(i)
Set findRenge = fn.Range.Duplicate
Do
If Not (findRenge.Style Is Nothing) Then
If findRenge.Style = ActiveDocument.Styles(styleName) Then
texts.Add findRenge.Duplicate
Exit Do
End If
End If
With findRenge.Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = styleName
.text = ""
.Replacement.text = ""
.Format = True
.Forward = True
.Wrap = wdFindStop

If Not .Execute Then Exit Do

texts.Add findRenge.Duplicate
findRenge.Collapse wdCollapseEnd
findRenge.End = fn.Range.End
If findRenge.text = "" Then Exit Do
End With
Loop
Next

orginalSelection.Select

End Sub

Function GetCurrrentSection() As Section

Dim sec As Section
For Each sec In ActiveDocument.Sections
If Selection.Start >= sec.Range.Start And Selection.Start <= sec.Range.End Then
Set GetCurrrentSection = sec
Exit Function
End If
Next

Err.Raise 111111, , "Current secton not found"

End Function

<--------------------------------------------------------

gmaxey · #2 02-11-2024, 09:36 AM

Susan,

If your friend is charging for every line of code then in my humble opinion, you were overcharged a bit. Yes, a TC field isn't picked up as you would expect. However, that doesn't mean there. Put TC fields in your footnotes and try:

Code:

Sub CreateTOCofFootnotes_CurrentSection()
Dim oSec As Section
Dim colTCFields As New Collection
  Set oSec = ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber))
  ScanSectionFootNotes oSec, colTCFields
  InsertTableOfContents colTCFields
lbl_Exit:
  Exit Sub
End Sub

Sub InsertTableOfContents(colTCFields As Collection)
Dim oRng As Range
Dim lngIndex As Long
Dim strEntry As String
  For lngIndex = 1 To colTCFields.Count
    Set oRng = colTCFields(lngIndex).Code
    strEntry = Right(oRng.Text, Len(oRng.Text) - 5)
    Selection.TypeText strEntry & " - " & oRng.Information(wdActiveEndAdjustedPageNumber) & vbCr
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection)
Dim oFN As Footnote
Dim oField As Field
  For Each oFN In oSec.Range.Footnotes
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        colTCFields.Add oField
      End If
    Next oField
  Next oFN
lbl_Exit:
  Exit Sub
End Sub

RRB · #3 02-11-2024, 09:52 AM

Well first of all thank you for the attention. My friend doesn't take by a line of code but by the hour. And this took him 2 hours (don't ask me to tell you what he takes for an hour of writing code. It is too painful for me

If I had had this morning my bank account would have more money in it. I tend to be a little impulsive

but I have been held up for a long time in my project and was willing to do anything to get back to full-time work on it.

But there is one thing that is not working: It is picking up TC fields that are after the section break. Which is not good for my needs. Can you fix that?

Thank You so much!

Susan

gmaxey · #4 02-11-2024, 10:51 AM

I didn't test for that. Sorry. I think replacing the current ScanSectionFootNotes with:

Code:

Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
  For lngIndex = 1 To oSec.Range.Footnotes.Count
    Set oFN = oSec.Range.Footnotes(lngIndex)
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        If oField.Code.Information(wdInFootnote) Then
          colTCFields.Add oField
        End If
      End If
    Next oField
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

... will resolve that.

RRB · #5 02-11-2024, 10:56 AM

Oh Romeo, Romeo, if you had only been here this morning I would not have wasted so much money....

gmaxey · #6 02-11-2024, 11:10 AM

I think it was the Outlaw Josie Wales who said, buzzard gotta eat same as the worm.

I only got interested in your macro because your friend had used find and replace to create a collection of ranges defined by an applied style. While if you just used TC fields, if they are there they are there and you just collect them.

Regardless, pleased you now have two macros that work and you are back to your task.

gmaxey · #7 02-12-2024, 08:30 AM

Based on my understanding of you actual requirement, I think this might work:

Code:

Option Explicit
Dim arrEntries() As String
Sub CreateCompositeTOC_CurrentSection()
Dim oSec As Section
Dim colTCFields As New Collection
  Set oSec = ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber))
  ScanSection oSec, colTCFields
  ScanSectionFootNotes oSec, colTCFields
  InsertTableOfContents colTCFields
  DisplayTOC
lbl_Exit:
  Exit Sub
End Sub

Sub InsertTableOfContents(colTCFields As Collection)
Dim oRng As Range
Dim lngIndex As Long
Dim strEntry As String

  ReDim arrEntries(colTCFields.Count - 1, 1)
  For lngIndex = 1 To colTCFields.Count
    Set oRng = colTCFields(lngIndex).Code
    strEntry = Right(oRng.Text, Len(oRng.Text) - 5)
    arrEntries(lngIndex - 1, 0) = strEntry
    arrEntries(lngIndex - 1, 1) = oRng.Information(wdActiveEndAdjustedPageNumber)
    'Selection.TypeText strEntry & " - " & oRng.Information(wdActiveEndAdjustedPageNumber) & vbCr
  Next lngIndex
  'Sort on page number
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
  'Sort on entry
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
  
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSection(oSec As Section, colTCFields As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
   For Each oField In oSec.Range.Fields
     If oField.Type = wdFieldTOCEntry Then
       colTCFields.Add oField
     End If
   Next oField
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
  For lngIndex = 1 To oSec.Range.Footnotes.Count
    Set oFN = oSec.Range.Footnotes(lngIndex)
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        If oField.Code.Information(wdInFootnote) Then
          colTCFields.Add oField
        End If
      End If
    Next oField
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

Sub DisplayTOC()
Dim oRng As Range
Dim lngIndex As Long
Dim oStyle As Style
  On Error Resume Next
  Set oStyle = ActiveDocument.Styles("CompositeTOC")
  If Err.Number <> 0 Then
    ActiveDocument.Styles.Add "CompositeTOC", wdStyleTypeParagraph
    With ActiveDocument.Styles("CompositeTOC")
      .BaseStyle = ActiveDocument.Styles("TOC 1")
      .ParagraphFormat.TabStops.Add Position:=InchesToPoints(6.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
      .NextParagraphStyle = ActiveDocument.Styles("CompositeTOC")
    End With
  End If
  On Error GoTo 0
  Set oRng = Selection.Range
  oRng.Style = "CompositeTOC"
  For lngIndex = 0 To UBound(arrEntries)
    oRng.Text = arrEntries(lngIndex, 0) & vbTab & arrEntries(lngIndex, 1) & vbCr
    oRng.Collapse wdCollapseEnd
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

gmaxey · #8 02-13-2024, 03:31 AM

I've worked with Susan offline a bit as her specific requirement includes only current section content. Below is a more general process to build a composite TOC from TC fields used in both main text and footnote story ranges of an entire document. Very limited testing, but it works well on a small sample document:

Code:

Option Explicit
Dim arrEntries() As String
Sub CreateCompositeTOC_CurrentSection()
Dim oSec As Section
Dim colTCFields As New Collection
Dim colBMs As New Collection
  Set oSec = ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber))
  ScanSection oSec, colTCFields, colBMs
  ScanSectionFootNotes oSec, colTCFields, colBMs
  BuildTOCContent colTCFields, colBMs
  DisplayTOC
lbl_Exit:
  Exit Sub
End Sub

Sub BuildTOCContent(colTCFields As Collection, colBMs As Collection)
Dim oRng As Range
Dim lngIndex As Long
Dim strEntry As String

  ReDim arrEntries(colTCFields.Count - 1, 2)
  For lngIndex = 1 To colTCFields.Count
    Set oRng = colTCFields(lngIndex).Code
    strEntry = Right(oRng.Text, Len(oRng.Text) - 5)
    If InStr(strEntry, "\l") > 0 Then
      strEntry = Mid(strEntry, 1, InStr(strEntry, "\l") - 2)
    End If
    strEntry = Replace(strEntry, "/" & Chr(34), Chr(34))
    strEntry = Replace(strEntry, "/" & ChrW(8220), ChrW(8220))
    strEntry = Replace(strEntry, "/" & ChrW(8221), ChrW(8221))
    arrEntries(lngIndex - 1, 0) = strEntry
    arrEntries(lngIndex - 1, 1) = oRng.Information(wdActiveEndAdjustedPageNumber)
    arrEntries(lngIndex - 1, 2) = colBMs.Item(lngIndex)
  Next lngIndex
  'Sort on page number
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
  'Sort on entry
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSection(oSec As Section, colTCFields As Collection, colBMs As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngFieldIndex As Long
  lngFieldIndex = 1
   For Each oField In oSec.Range.Fields
     If oField.Type = wdFieldTOCEntry Then
       oField.Code.Bookmarks.Add "Sec_" & oSec.Index & "Fld_" & lngFieldIndex, oField.Code
       colTCFields.Add oField
       colBMs.Add "Sec_" & oSec.Index & "Fld_" & lngFieldIndex
       lngFieldIndex = lngFieldIndex + 1
     End If
   Next oField
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection, colBMs As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
Dim lngFieldIndex
  For lngIndex = 1 To oSec.Range.Footnotes.Count
    Set oFN = oSec.Range.Footnotes(lngIndex)
    lngFieldIndex = 1
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        If oField.Code.Information(wdInFootnote) Then
          oField.Code.Bookmarks.Add "Sec_" & oSec.Index & "FN_" & lngIndex & "Fld_" & lngFieldIndex, oField.Code
          colTCFields.Add oField
          colBMs.Add "Sec_" & oSec.Index & "FN_" & lngIndex & "Fld_" & lngFieldIndex
          lngFieldIndex = lngFieldIndex + 1
        End If
      End If
    Next oField
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

Sub DisplayTOC()
Dim oRng As Range
Dim lngIndex As Long
Dim oStyle As Style
Dim oRngHL As Range
Dim oHL As Hyperlink
  On Error Resume Next
  Set oStyle = ActiveDocument.Styles("CompositeTOC")
  If Err.Number <> 0 Then
    ActiveDocument.Styles.Add "CompositeTOC", wdStyleTypeParagraph
    With ActiveDocument.Styles("CompositeTOC")
      .BaseStyle = ActiveDocument.Styles("TOC 1")
      .ParagraphFormat.TabStops.Add Position:=InchesToPoints(6.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
      .NextParagraphStyle = ActiveDocument.Styles("CompositeTOC")
    End With
  End If
  On Error GoTo 0
  Set oRng = Selection.Range
  oRng.Style = "CompositeTOC"
  For lngIndex = 0 To UBound(arrEntries)
    oRng.Text = arrEntries(lngIndex, 0) & vbTab & arrEntries(lngIndex, 1) & vbCr
    Set oRngHL = oRng.Duplicate
    oRngHL.End = oRngHL.End - 1
    oRngHL.Hyperlinks.Add oRngHL, , arrEntries(lngIndex, 2)
    oRng.Collapse wdCollapseEnd
    oRngHL.Collapse wdCollapseEnd
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to find a header based on a value in another cell	Tphil413	Excel Programming	2	07-23-2019 09:59 AM
Macro to insert an image based as told	puff	Word VBA	1	05-24-2018 03:55 PM
a macro that can copy data from copy.xls to our current excel macro.xls based on criteria:	udhaya	Excel Programming	1	11-12-2015 10:12 AM
Formatting Macro based on Zoom (PageScale)	thundercats9595	Excel Programming	6	02-06-2014 09:49 PM
Macro based on cell value	ubns	Excel Programming	1	05-07-2012 04:03 AM