Programming a TOC to have page counts (not page location)

[Krystal]

Here is what I am trying to accomplish using Word 2007 and XP:

I want to create a TOC with the Title and Individual Section Page Counts
using separate Individual Files to look like this:

Section No. Title No. of Pages
200500 General Provisions 5
200505 Project Closeout and Start-up 10

Information:
• The section number and title are the file names (i.e. 2000500 General
Provisions.doc) and are also included in the beginning of each document as
well as a title (with a set style).
• All files are located in the same folder.

Here is the current macro I am working with that was provided by someone on
this site: This macro does not input the correct page count for each file,
in fact it places the 1st file’s page count for each file instead.

Looks like this:

200500 GENERAL PROVISIONS test.doc 3
SECTION 200523 VALVES DRAFT with index codes.doc 3
Table style settings-example.doc 3

The macro will put the correct page count ONLY if all the files are open.
But considering I am trying to use this macro for 50+ documents at a time,
this is not a viable solution. Any help would be GREATLY appreciated; I’ve
been working on this for months. Thanks.


Sub TOCpgcnt()
'
' TOCpgcnt Macro
'
'
Dim fd As FileDialog
Dim PathToUse As String
Dim SourceFile As String
Dim Target As Document
Dim Source As Document
Dim numpages As Long

Set Target = ActiveDocument
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
SourceFile = Dir$(PathToUse & "*.doc")
Do While SourceFile <> ""
Set Source = Documents.Open(PathToUse & SourceFile)
numpages = Source.BuiltInDocumentProperties(wdPropertyPages)
Target.Range.InsertAfter Source.Name & vbTab & numpages & vbCrLf
Source.Close wdDoNotSaveChanges
SourceFile = Dir$
Loop

End Sub

 

[Doug Robbins - Word MVP]

I think that it is a timing issue,

Here is another method, that will take a little bit longer, but does produce
the desired result:

Dim fd As FileDialog
Dim PathToUse As String
Dim SourceFile As String
Dim Target As Document
Dim Source As Document
Dim numpages As Long

Set Target = ActiveDocument
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
SourceFile = Dir$(PathToUse & "*.doc")
Do While SourceFile <> ""
Set Source = Documents.Open(PathToUse & SourceFile)
With Source
.Range.Select
Selection.Collapse wdCollapseEnd
numpages = Selection.Information(wdActiveEndPageNumber)
End With
Target.Range.InsertAfter Source.Name & vbTab & numpages & vbCrLf
Source.Close wdDoNotSaveChanges
Set Source = Nothing
SourceFile = Dir$
Loop


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Krystal]

Doug,

Thank you! I'm sure you are correct about the time-out issue. This one
worked, so I am happy.

Question for you:
Is it possible to program the macro to pull the text from a specific style
in the word document? Since the current macro is pulling the file name, I
will have to make some minor changes after the macro is complete (remove the
..doc, etc). But if I could get it to pick out the title inside the document
instead (for example, the style named "SCT")…that would be even better.

Thanks,
Krystal

 

[Doug Robbins - Word MVP]

To get the first instance of the text in the document to which the style SCT
is applied, use

Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("SCT")
Selection.Find.Execute FindText:="", Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False
MsgBox Selection.Text


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Krystal]

OK, one more question, where exactly would I put this information into the
current macro? Or would my previous macro need to be recreated?

Thanks!

 

[Doug Robbins - Word MVP]

Use:

Dim fd As FileDialog
Dim PathToUse As String
Dim SourceFile As String
Dim Target As Document
Dim Source As Document
Dim numpages As Long
Dim strTitle as string

Set Target = ActiveDocument
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
SourceFile = Dir$(PathToUse & "*.doc")
Do While SourceFile <> ""
Set Source = Documents.Open(PathToUse & SourceFile)
With Source
.Range.Select
Selection.Collapse wdCollapseEnd
numpages = Selection.Information(wdActiveEndPageNumber)
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("SCT")
Selection.Find.Execute FindText:="", Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False
strTitle = Selection.Text
End With
Target.Range.InsertAfter strTitle & vbTab & numpages & vbCrLf
Source.Close wdDoNotSaveChanges
Set Source = Nothing
SourceFile = Dir$
Loop


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Krystal]

Thank you! It works wonderfully!

Use:

Dim fd As FileDialog
Dim PathToUse As String
Dim SourceFile As String
Dim Target As Document
Dim Source As Document
Dim numpages As Long
Dim strTitle as string

Set Target = ActiveDocument
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
SourceFile = Dir$(PathToUse & "*.doc")
Do While SourceFile <> ""
Set Source = Documents.Open(PathToUse & SourceFile)
With Source
.Range.Select
Selection.Collapse wdCollapseEnd
numpages = Selection.Information(wdActiveEndPageNumber)
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("SCT")
Selection.Find.Execute FindText:="", Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False
strTitle = Selection.Text
End With
Target.Range.InsertAfter strTitle & vbTab & numpages & vbCrLf
Source.Close wdDoNotSaveChanges
Set Source = Nothing
SourceFile = Dir$
Loop


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Krystal]

Thank you! It works wonderfully!

Use:

Dim fd As FileDialog
Dim PathToUse As String
Dim SourceFile As String
Dim Target As Document
Dim Source As Document
Dim numpages As Long
Dim strTitle as string

Set Target = ActiveDocument
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder containing the files."
If .Show = -1 Then
PathToUse = .SelectedItems(1) & "\"
Else
End If
End With
Set fd = Nothing
SourceFile = Dir$(PathToUse & "*.doc")
Do While SourceFile <> ""
Set Source = Documents.Open(PathToUse & SourceFile)
With Source
.Range.Select
Selection.Collapse wdCollapseEnd
numpages = Selection.Information(wdActiveEndPageNumber)
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("SCT")
Selection.Find.Execute FindText:="", Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop, MatchCase:=False
strTitle = Selection.Text
End With
Target.Range.InsertAfter strTitle & vbTab & numpages & vbCrLf
Source.Close wdDoNotSaveChanges
Set Source = Nothing
SourceFile = Dir$
Loop


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Doug Robbins - Word MVP]

You're welcome.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com