#1
|
||||
|
||||
Macro for enyone and everyone TOC based on FN
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 <-------------------------------------------------------- |
#2
|
|||
|
|||
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 |
#3
|
||||
|
||||
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 |
#4
|
|||
|
|||
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. |
#5
|
||||
|
||||
Oh Romeo, Romeo, if you had only been here this morning I would not have wasted so much money....
|
#6
|
|||
|
|||
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. |
#7
|
|||
|
|||
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 |
#8
|
|||
|
|||
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 Last edited by gmaxey; 02-13-2024 at 02:39 PM. |
|
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 |