F
Fanning
I'm creating a table of contents. The code gets progressively slower with
each entry processed. The first several entries take less than a second, but
the time increases up to seconds near the end. An example with 364 entries
is taking 26 minutes.
Here is the code:
Slow portion is marked with *****
Private Sub PrintTOCEntries()
Dim FuncName As String
FuncName = "PrintTOCEntries"
On Error GoTo ErrorHandler
Dim TOCIndex As Long, TitleIndex As Long, TitlePageNumberFound As Boolean
Dim strToCWorkingFile As String
strToCWorkingFile = ToCWorkingFilePath()
With obj
'Create the TOC document and prepare it for the TOC entries
' create a new document
Set .wordDoc =
..WordApp.Documents.Add(DocumentType:=wdNewBlankDocument, Visible:=True)
.WordApp.WordBasic.FilePrintSetup Printer:=PDFPrinter,
DoNotSetAsSysDefault:=1
' add book type, type the book name
.WordApp.Selection.TypeText Text:=" "
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.WordApp.Selection.TypeText Text:= _
UCase$(mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strSurveyTypeTag).Text)
' add name
.WordApp.Selection.TypeParagraph
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.WordApp.Selection.TypeText Text:= _
mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strCNameTag).Text & ", " & _
mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strNameTag).Text
.WordApp.Selection.TypeParagraph
.WordApp.Selection.TypeParagraph
' add TOC Heading text
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.Font.Name = HeaderFooterFontNameMSWORD
.WordApp.Selection.Font.Underline = wdUnderlineSingle
.WordApp.Selection.TypeText "TABLE OF CONTENTS"
' set the font. this will affect all following TOC text
obj.wordDoc.Styles("Normal").Font.Name = HeaderFooterFontNameMSWORD
' make sure new TOC item is selected
.WordApp.Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
' underline and center the TOC Heading
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
' set page number style for this section
.WordApp.Selection.Sections(1).Headers(1).PageNumbers.NumberStyle = _
wdPageNumberStyleLowercaseRoman
.WordApp.Selection.EndKey Unit:=wdStory ' move to end to get past
space which is selected
.WordApp.Selection.MoveEnd ' move to the end of this section
.WordApp.Selection.MoveRight ' move one position to the right
.WordApp.Selection.TypeParagraph ' add line after TOC heading
.WordApp.Selection.Font.Bold = False ' leave the TOC in NON-Bold
' add a bookmark (titles will be after this mark and TOC will be
before it)
With .wordDoc.Bookmarks
.Add Name:="TOCStart"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
.WordApp.Selection.TypeText " " ' this space allows TOC to be between
bookmarks
' add a bookmark (this mark will be just after the TOC)
With .wordDoc.Bookmarks
.Add Name:="TOCEnd"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
.WordApp.Selection.InsertBreak Type:=wdSectionBreakNextPage
' The following loop creates each TOC entry in its own document section
'
' Set the starting page number for content item
' Set the starting page number for each title item to the page with
' the corresponding content item.
Dim li_toc_size As Integer
li_toc_size = UBound(TOCEntries)
For TOCIndex = 1 To li_toc_size
' create a new section
.WordApp.Selection.InsertBreak Type:=wdSectionBreakNextPage
' move to end of doc (after new section break) for adding this TOC
entry
.WordApp.Selection.EndKey wdStory
' make sure target page number is set
If TOCEntries(TOCIndex).TOCLineType = Content Then
TOCEntries(TOCIndex).TOCTargetPage = _
Sections(TOCEntries(TOCIndex).TOCTargetSectionIndex).StartingPageNumber
Else
' if this is a title-only entry, give it the
' page number of the next content section
TitleIndex = TOCIndex + 1
TitlePageNumberFound = False
Do While (TitleIndex <= UBound(TOCEntries)) _
And (TitlePageNumberFound = False)
If TOCEntries(TitleIndex).TOCLineType = Content Then
TOCEntries(TOCIndex).TOCTargetPage = _
Sections(TOCEntries(TitleIndex). _
TOCTargetSectionIndex).StartingPageNumber
TitlePageNumberFound = True
End If
TitleIndex = TitleIndex + 1
Loop
End If
' add a space and select it
.WordApp.Selection.TypeText Text:=" "
.WordApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1
.WordApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
' set TOC item to heading style to reflect its level in the TOC
.WordApp.Selection.Style = _
.wordDoc.Styles("Heading " & _
CStr(TOCEntries(TOCIndex).TOCLevel))
' add TOC item text
.WordApp.Selection.TypeText Text:=TOCEntries(TOCIndex).TOCString
' *****This code progressively gets slower, from under 1 sec to 6 sec -
between here
' set page number for this section
With .WordApp.Selection.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = True
.StartingNumber = TOCEntries(TOCIndex).TOCTargetPage
End With
.WordApp.Selection.Sections(1).Footers(1).PageNumbers.Add
PageNumberAlignment:= _
wdAlignPageNumberRight, FirstPage:=True
'****** and here
Next TOCIndex
' jump to bookmark which is just after TOC Header and create table of
contents
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCStart"
With .wordDoc
.TablesOfContents.Add obj.WordApp.Selection.Range,
RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=7, _
IncludePageNumbers:=True, AddedStyles:="" ', _
UseHyperlinks:=True, HidePageNumbersInWeb:=True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
' jump back to top of document and refresh table of contents
' this will make sure the number of pages of TOC is correct
' jump to bookmark which is just after TOC Header and refresh table of
contents
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCStart"
.WordApp.Selection.fields.Update
' add the banners to the document
Sections(1).AddHeaderFooterToWordDocument .wordDoc, _
(Sections(1).topLEFTString & vbTab & _
vars.strClass & vbTab), Sections(1).bottomString(), _
UseRomanNumerals:=True, bOnlyApplyToFirstSection:=True
' jump back to top of document and refresh table of contents
' this will make sure the style of page numbers in the TOC is correct
.WordApp.Selection.HomeKey Unit:=wdStory
.WordApp.Selection.fields.Update
' lock the TOC field so that it is not changed when we delete
' all other pages and print since it tries to update the TOC when
' it prints
.wordDoc.fields.Locked = True
' delete everything which is not the TOC
' jump to bookmark which is just after TOC Header
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCEnd"
' extend selection to end of document
.WordApp.Selection.EndKey Unit:=wdStory, Extend:=wdExtend
' delete selection
.WordApp.Selection.Delete Unit:=wdCharacter, Count:=1
'.WordApp.Selection.TypeText Text:="<Test of Text after delete>"
' print the Word document to PDF, making sure output file does not have
..pdf
' since the print operation will append it
.wordDoc.PrintOut PrintToFile:=False, _
OutputFileName:=StripPDFExtension(strToCWorkingFile), Background:=False
VBA.Interaction.DoEvents
' close the Word Document
obj.wordDoc.Close False
Set obj.wordDoc = Nothing
End With 'obj
Exit Sub
each entry processed. The first several entries take less than a second, but
the time increases up to seconds near the end. An example with 364 entries
is taking 26 minutes.
Here is the code:
Slow portion is marked with *****
Private Sub PrintTOCEntries()
Dim FuncName As String
FuncName = "PrintTOCEntries"
On Error GoTo ErrorHandler
Dim TOCIndex As Long, TitleIndex As Long, TitlePageNumberFound As Boolean
Dim strToCWorkingFile As String
strToCWorkingFile = ToCWorkingFilePath()
With obj
'Create the TOC document and prepare it for the TOC entries
' create a new document
Set .wordDoc =
..WordApp.Documents.Add(DocumentType:=wdNewBlankDocument, Visible:=True)
.WordApp.WordBasic.FilePrintSetup Printer:=PDFPrinter,
DoNotSetAsSysDefault:=1
' add book type, type the book name
.WordApp.Selection.TypeText Text:=" "
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.WordApp.Selection.TypeText Text:= _
UCase$(mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strSurveyTypeTag).Text)
' add name
.WordApp.Selection.TypeParagraph
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.WordApp.Selection.TypeText Text:= _
mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strCNameTag).Text & ", " & _
mvarBookXML.selectSingleNode(strBookRootName). _
Attributes.getNamedItem(strNameTag).Text
.WordApp.Selection.TypeParagraph
.WordApp.Selection.TypeParagraph
' add TOC Heading text
.WordApp.Selection.Font.Color = wdColorBlack
.WordApp.Selection.Font.Size = HeaderFooterFontSize
.WordApp.Selection.Font.Bold = True
.WordApp.Selection.Font.Name = HeaderFooterFontNameMSWORD
.WordApp.Selection.Font.Underline = wdUnderlineSingle
.WordApp.Selection.TypeText "TABLE OF CONTENTS"
' set the font. this will affect all following TOC text
obj.wordDoc.Styles("Normal").Font.Name = HeaderFooterFontNameMSWORD
' make sure new TOC item is selected
.WordApp.Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
' underline and center the TOC Heading
.WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
' set page number style for this section
.WordApp.Selection.Sections(1).Headers(1).PageNumbers.NumberStyle = _
wdPageNumberStyleLowercaseRoman
.WordApp.Selection.EndKey Unit:=wdStory ' move to end to get past
space which is selected
.WordApp.Selection.MoveEnd ' move to the end of this section
.WordApp.Selection.MoveRight ' move one position to the right
.WordApp.Selection.TypeParagraph ' add line after TOC heading
.WordApp.Selection.Font.Bold = False ' leave the TOC in NON-Bold
' add a bookmark (titles will be after this mark and TOC will be
before it)
With .wordDoc.Bookmarks
.Add Name:="TOCStart"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
.WordApp.Selection.TypeText " " ' this space allows TOC to be between
bookmarks
' add a bookmark (this mark will be just after the TOC)
With .wordDoc.Bookmarks
.Add Name:="TOCEnd"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
.WordApp.Selection.InsertBreak Type:=wdSectionBreakNextPage
' The following loop creates each TOC entry in its own document section
'
' Set the starting page number for content item
' Set the starting page number for each title item to the page with
' the corresponding content item.
Dim li_toc_size As Integer
li_toc_size = UBound(TOCEntries)
For TOCIndex = 1 To li_toc_size
' create a new section
.WordApp.Selection.InsertBreak Type:=wdSectionBreakNextPage
' move to end of doc (after new section break) for adding this TOC
entry
.WordApp.Selection.EndKey wdStory
' make sure target page number is set
If TOCEntries(TOCIndex).TOCLineType = Content Then
TOCEntries(TOCIndex).TOCTargetPage = _
Sections(TOCEntries(TOCIndex).TOCTargetSectionIndex).StartingPageNumber
Else
' if this is a title-only entry, give it the
' page number of the next content section
TitleIndex = TOCIndex + 1
TitlePageNumberFound = False
Do While (TitleIndex <= UBound(TOCEntries)) _
And (TitlePageNumberFound = False)
If TOCEntries(TitleIndex).TOCLineType = Content Then
TOCEntries(TOCIndex).TOCTargetPage = _
Sections(TOCEntries(TitleIndex). _
TOCTargetSectionIndex).StartingPageNumber
TitlePageNumberFound = True
End If
TitleIndex = TitleIndex + 1
Loop
End If
' add a space and select it
.WordApp.Selection.TypeText Text:=" "
.WordApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1
.WordApp.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
' set TOC item to heading style to reflect its level in the TOC
.WordApp.Selection.Style = _
.wordDoc.Styles("Heading " & _
CStr(TOCEntries(TOCIndex).TOCLevel))
' add TOC item text
.WordApp.Selection.TypeText Text:=TOCEntries(TOCIndex).TOCString
' *****This code progressively gets slower, from under 1 sec to 6 sec -
between here
' set page number for this section
With .WordApp.Selection.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.HeadingLevelForChapter = 0
.IncludeChapterNumber = False
.ChapterPageSeparator = wdSeparatorHyphen
.RestartNumberingAtSection = True
.StartingNumber = TOCEntries(TOCIndex).TOCTargetPage
End With
.WordApp.Selection.Sections(1).Footers(1).PageNumbers.Add
PageNumberAlignment:= _
wdAlignPageNumberRight, FirstPage:=True
'****** and here
Next TOCIndex
' jump to bookmark which is just after TOC Header and create table of
contents
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCStart"
With .wordDoc
.TablesOfContents.Add obj.WordApp.Selection.Range,
RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=7, _
IncludePageNumbers:=True, AddedStyles:="" ', _
UseHyperlinks:=True, HidePageNumbersInWeb:=True
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With
' jump back to top of document and refresh table of contents
' this will make sure the number of pages of TOC is correct
' jump to bookmark which is just after TOC Header and refresh table of
contents
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCStart"
.WordApp.Selection.fields.Update
' add the banners to the document
Sections(1).AddHeaderFooterToWordDocument .wordDoc, _
(Sections(1).topLEFTString & vbTab & _
vars.strClass & vbTab), Sections(1).bottomString(), _
UseRomanNumerals:=True, bOnlyApplyToFirstSection:=True
' jump back to top of document and refresh table of contents
' this will make sure the style of page numbers in the TOC is correct
.WordApp.Selection.HomeKey Unit:=wdStory
.WordApp.Selection.fields.Update
' lock the TOC field so that it is not changed when we delete
' all other pages and print since it tries to update the TOC when
' it prints
.wordDoc.fields.Locked = True
' delete everything which is not the TOC
' jump to bookmark which is just after TOC Header
.WordApp.Selection.GoTo What:=wdGoToBookmark, Name:="TOCEnd"
' extend selection to end of document
.WordApp.Selection.EndKey Unit:=wdStory, Extend:=wdExtend
' delete selection
.WordApp.Selection.Delete Unit:=wdCharacter, Count:=1
'.WordApp.Selection.TypeText Text:="<Test of Text after delete>"
' print the Word document to PDF, making sure output file does not have
' since the print operation will append it
.wordDoc.PrintOut PrintToFile:=False, _
OutputFileName:=StripPDFExtension(strToCWorkingFile), Background:=False
VBA.Interaction.DoEvents
' close the Word Document
obj.wordDoc.Close False
Set obj.wordDoc = Nothing
End With 'obj
Exit Sub