L
LoriM
What I am trying to do it to go through a list of Word documents and create
an array containing two parameters for each TOC entry. The first entry is
made up of the filename, a "|" as a delimiter and the TOC entry text
(includes all levels up to that point concatenated with a >). The second
entry of the array is the page number associated with the TOC entry. This
works as it is but it is painfully slow. I added the flag that is set when
the TOC Title paragraph is found to be able to stop the processing once all
of the TOC # entries had been processed and that has helped some but this is
still very slow. Is there a different approach that would speed this up?
Thanks.
Private Sub GetDocumentsHeadingsForFileInPath(wordFileName, wordFilePath)
Dim oApp As Object
Dim oDoc As Object
Dim oSec As Object
Dim NumSections As Integer
Dim foundTOC As Boolean
Dim st As String
Dim tocLastValues(9) As String
'Start Word and open the document.
Set oApp = CreateObject("Word.Application")
On Error Resume Next
Set oDoc = oApp.Documents.Open(wordFilePath)
If Not oDoc Is Nothing Then
'Iterate each paragraph in the document to find the table of content
entries
'Get their level, text and page values
'Once you have found the Table of Contents, stop at the next style
that is not a TOC #
NumSections = oDoc.Paragraphs.Count
foundTOC = False
For i = 1 To NumSections
Set oSec = oDoc.Paragraphs(i)
If Not oSec Is Nothing Then
st = oSec.Style
If st = "TOC Title" Then
foundTOC = True
ElseIf Left(st, 3) = "TOC" Then
currentLevel = Right(st, 1)
currenttext = Split(oSec.Range.Text, vbTab)(0)
currentPageNo = Split(oSec.Range.Text, vbTab)(1)
currenttext = GetFullTextForLevel(tocLastValues,
currentLevel, currenttext)
'Debug.Print "Level: " & currentLevel & " Text: " &
currenttext & " Page: " & currentPageNo
allValues(0, noEntries) = wordFileName & "|" & currenttext
allValues(1, noEntries) = currentPageNo
noEntries = noEntries + 1
ElseIf foundTOC Then
Exit For
End If
End If
Next
End If
'Close the document without saving changes and quit Word.
On Error Resume Next
oDoc.Close
oApp.Quit
Set oSec = Nothing
Set oDoc = Nothing
Set oApp = Nothing
End Sub
Private Function GetFullTextForLevel(currentValues, thisLevel, levelText)
Dim i As Integer
Dim tempText As String
tempText = ""
'blank out everything above this level
For i = thisLevel To 9
currentValues(i) = ""
Next
'set this level's text
currentValues(thisLevel) = levelText
'build the string for this level
For i = 1 To thisLevel - 1
tempText = tempText & currentValues(i) & " > "
Next
tempText = tempText & currentValues(thisLevel)
GetFullTextForLevel = tempText
End Function
an array containing two parameters for each TOC entry. The first entry is
made up of the filename, a "|" as a delimiter and the TOC entry text
(includes all levels up to that point concatenated with a >). The second
entry of the array is the page number associated with the TOC entry. This
works as it is but it is painfully slow. I added the flag that is set when
the TOC Title paragraph is found to be able to stop the processing once all
of the TOC # entries had been processed and that has helped some but this is
still very slow. Is there a different approach that would speed this up?
Thanks.
Private Sub GetDocumentsHeadingsForFileInPath(wordFileName, wordFilePath)
Dim oApp As Object
Dim oDoc As Object
Dim oSec As Object
Dim NumSections As Integer
Dim foundTOC As Boolean
Dim st As String
Dim tocLastValues(9) As String
'Start Word and open the document.
Set oApp = CreateObject("Word.Application")
On Error Resume Next
Set oDoc = oApp.Documents.Open(wordFilePath)
If Not oDoc Is Nothing Then
'Iterate each paragraph in the document to find the table of content
entries
'Get their level, text and page values
'Once you have found the Table of Contents, stop at the next style
that is not a TOC #
NumSections = oDoc.Paragraphs.Count
foundTOC = False
For i = 1 To NumSections
Set oSec = oDoc.Paragraphs(i)
If Not oSec Is Nothing Then
st = oSec.Style
If st = "TOC Title" Then
foundTOC = True
ElseIf Left(st, 3) = "TOC" Then
currentLevel = Right(st, 1)
currenttext = Split(oSec.Range.Text, vbTab)(0)
currentPageNo = Split(oSec.Range.Text, vbTab)(1)
currenttext = GetFullTextForLevel(tocLastValues,
currentLevel, currenttext)
'Debug.Print "Level: " & currentLevel & " Text: " &
currenttext & " Page: " & currentPageNo
allValues(0, noEntries) = wordFileName & "|" & currenttext
allValues(1, noEntries) = currentPageNo
noEntries = noEntries + 1
ElseIf foundTOC Then
Exit For
End If
End If
Next
End If
'Close the document without saving changes and quit Word.
On Error Resume Next
oDoc.Close
oApp.Quit
Set oSec = Nothing
Set oDoc = Nothing
Set oApp = Nothing
End Sub
Private Function GetFullTextForLevel(currentValues, thisLevel, levelText)
Dim i As Integer
Dim tempText As String
tempText = ""
'blank out everything above this level
For i = thisLevel To 9
currentValues(i) = ""
Next
'set this level's text
currentValues(thisLevel) = levelText
'build the string for this level
For i = 1 To thisLevel - 1
tempText = tempText & currentValues(i) & " > "
Next
tempText = tempText & currentValues(thisLevel)
GetFullTextForLevel = tempText
End Function