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

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