TOC from page header?

[pirre]

I have a word document with many pages. At the head of each page there is a text.
Same text can be on many pages. If it's so, the same text is after each other.
I have tried to create a table of contents of this text, but I am stuck completely.


First I wanna create a blank first page. Then I wanna create a table of contents based on the
page header text in the document.


Ex:


"Test text 1 from main page".........Page 1-3
"Test Text 2 from main page".........Page 4
"Test Text 3 from main page".........Page 5-7

and so on...


How can I do that with VBA?

[gmayor]

Without access to the document this is somewhat hit and miss. Presumably the page headers reflect the sections in the document. That being the case, the following should point you in the right direction

Sub Macro1()
Dim oSection As Section
Dim oRng As Range
Dim sIndex As String: sIndex = ""
Dim iStart As Integer, iEnd As Integer
Dim oHeader As HeaderFooter
For Each oSection In ActiveDocument.Sections
Set oRng = oSection.Range
oRng.Collapse 1
iStart = oRng.Information(wdActiveEndPageNumber)
Set oRng = oSection.Range
oRng.Collapse 0
If oSection.Index = ActiveDocument.Sections.Count Then
iEnd = oRng.Information(wdActiveEndPageNumber)
Else
iEnd = oRng.Information(wdActiveEndPageNumber) - 1
End If
Set oRng = oSection.Headers(wdHeaderFooterPrimary).Range
oRng.End = oRng.End - 1
If iStart = iEnd Then
sIndex = sIndex & vbCr & oRng.Text & vbTab & "Page " & iStart
Else
sIndex = sIndex & vbCr & oRng.Text & vbTab & "Page " & iStart & "-" & iEnd
End If
Next oSection
Set oRng = ActiveDocument.Range
oRng.Collapse 1
oRng.InsertBreak wdSectionBreakNextPage
oRng.Start = oRng.Start - 1
oRng.Collapse 1
oRng.Text = sIndex
Set oHeader = ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary)
oHeader.LinkToPrevious = False
Set oHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary)
oHeader.Range.Text = "Table of Contents"
lbl_Exit:
Exit Sub
End Sub

[pirre]

This is almost exactly what I was looking for! Thousand thanks.


A follow-up question, if I instead of tab wants points (as standard TOC), how do I do it to get the page numbering to start on the same tab stop?
Can I instead to add "Table of contents" in the page header put it as a head? How do I change the font and size on this page? See picture what I mean.

17541

[gmayor]

It's a relatively minor change, but as I don't know how your document is formatted, you need to apply the settings you require to the range. You can do that with the following macro


Sub FormatIndex(orng As Range)
With orng.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 11
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.CollapsedByDefault = False
.TabStops.ClearAll
.TabStops.Add _
Position:=CentimetersToPoints(16), _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
End With
lbl_Exit:
Exit Sub
End SubCall this macro from the existing code by adding a line


orng.Text = sIndex 'This line exists
FormatIndex orng 'add this line

If you don't want 'Page' on each line, then change the lines that create the index lines to

If iStart = iEnd Then
sIndex = sIndex & vbCr & orng.Text & vbTab & iStart
Else
sIndex = sIndex & vbCr & orng.Text & vbTab & iStart & "-" & iEnd
End If

[pirre]

Fantastic! This works great!


If I want to add a page number in the footer that begins
on the real side and not on this TOC. The TOC can sometimes be
more than one page. I have try to add page numbers in the footer,
but there will be on all sides, including the TOC.

[gmayor]

I included a section break in the code so you can put your TOC in that last section and format the TOC footer to have whatever numbering you require, independently of the body of the document.

[pirre]

I can not get this to work. Can you show me what you mean?

[pirre]

Whatever I do, I get pagination on all sides including the first page which is TOC. Are you able to show me how I can add page numbers in the page footer, starting on the first page after the TOC?

[Kilroy]

I got it to work I think. When I run it, it basically takes the info from the header from the second page on. My first page header is different and it left out the bottom row of cells from the first page header. For this to be an ideal script it would take all the info from page 1 header and list it as page 1. If the headers were the same for pages 1 -5 it would return the header info and say pages 1 - 5. If pages 6 - 20 had a different header it would return header info and pages 6 - 20. If all headers were the same it would return one line saying header info pages 1 - 20. Also the way it is numbering each line screws up the document numbering. Is there a way to resolve this? I lowered the value of the position of the text start from 16 to 2 since some of my titles are long:
"Position:=CentimetersToPoints(2), _"


Pirre try this:



Sub Macro1()
Dim oSection As Section
Dim orng As Range
Dim sIndex As String: sIndex = ""
Dim iStart As Integer, iEnd As Integer
Dim oHeader As HeaderFooter
For Each oSection In ActiveDocument.Sections
Set orng = oSection.Range
orng.Collapse 1
iStart = orng.Information(wdActiveEndPageNumber)
Set orng = oSection.Range
orng.Collapse 0
If oSection.Index = ActiveDocument.Sections.Count Then
iEnd = orng.Information(wdActiveEndPageNumber)
Else
iEnd = orng.Information(wdActiveEndPageNumber) - 1
End If
Set orng = oSection.Headers(wdHeaderFooterPrimary).Range
orng.End = orng.End - 1
If iStart = iEnd Then
sIndex = sIndex & vbCr & orng.Text & vbTab & iStart
Else
sIndex = sIndex & vbCr & orng.Text & vbTab & iStart & "-" & iEnd
End If
Next oSection
Set orng = ActiveDocument.Range
orng.Collapse 1
orng.InsertBreak wdSectionBreakNextPage
orng.Start = orng.Start - 1
orng.Collapse 1
orng.Text = sIndex
FormatIndex orng
Set oHeader = ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary)
oHeader.LinkToPrevious = False
Set oHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary)
oHeader.Range.Text = "Table of Contents"
lbl_Exit:
Exit Sub
End Sub
Sub FormatIndex(orng As Range)
With orng.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 11
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.CollapsedByDefault = False
.TabStops.ClearAll
.TabStops.Add _
Position:=CentimetersToPoints(2), _
Alignment:=wdAlignTabRight, _
Leader:=wdTabLeaderDots
End With
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

The above code actual works absolutely perfect if you don't have numbered paragraphs