Macro to extract headings

J

jkmar5

I need a macro that opens all of the word documents in specific folder,
extracts the document headings (what you see in the outline view) and pastes
all of the headings into a new document. I have a macro that extracts the
headings (see below).

The problem is, I have to run this macro on each file individually and it
puts the headings in a separate document for each file. I would like to have
one document with all of the headings from all of the files, one right after
each other. I’ve never been able to figure out how to write macros that run
through all the files in a folder. If you have any suggestions, I would
really appreciate your help. Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
 
G

Graham Mayor

You need something like

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog 'Pick folder containing the files
.Title = "Select Folder containing the documents to be modifed and click
OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
PathToUse = fDialog.SelectedItems.Item(1)
If Right(PathToUse, 1) <> "\" Then PathToUse = PathToUse + "\"
End With

If Documents.Count > 0 Then 'close any open documents
Documents.Close savechanges:=wdPromptToSaveChanges
End If

myFile = Dir$(PathToUse & "*.doc")

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
I need a macro that opens all of the word documents in specific
folder, extracts the document headings (what you see in the outline
view) and pastes all of the headings into a new document. I have a
macro that extracts the headings (see below).

The problem is, I have to run this macro on each file individually
and it puts the headings in a separate document for each file. I
would like to have one document with all of the headings from all of
the files, one right after each other. I've never been able to figure
out how to write macros that run through all the files in a folder.
If you have any suggestions, I would really appreciate your help.
Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
Click to expand...
 
J

jkmar5

Thank you very much for your help. I am getting an error message at the line
"Dim fDialog as FileDialog." The error says "Compile Error. User-defined type
not defined." Do you know why I'm getting an error and how I can fix it?

Thanks.

Graham Mayor said:
You need something like

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog 'Pick folder containing the files
.Title = "Select Folder containing the documents to be modifed and click
OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
PathToUse = fDialog.SelectedItems.Item(1)
If Right(PathToUse, 1) <> "\" Then PathToUse = PathToUse + "\"
End With

If Documents.Count > 0 Then 'close any open documents
Documents.Close savechanges:=wdPromptToSaveChanges
End If

myFile = Dir$(PathToUse & "*.doc")

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
I need a macro that opens all of the word documents in specific
folder, extracts the document headings (what you see in the outline
view) and pastes all of the headings into a new document. I have a
macro that extracts the headings (see below).

The problem is, I have to run this macro on each file individually
and it puts the headings in a separate document for each file. I
would like to have one document with all of the headings from all of
the files, one right after each other. I've never been able to figure
out how to write macros that run through all the files in a folder.
If you have any suggestions, I would really appreciate your help.
Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
Click to expand...
Click to expand...
 
G

Graham Mayor

There should not be a period after FileDialog
If that doesn't fix it, use the following less elegant folder selection
routine

Sub PrintHeadings()
Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer

' Get the folder containing the files
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

'Close any documents that may be open
If Documents.Count > 0 Then
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

FirstLoop = True

If Left(PathToUse, 1) = Chr(34) Then
PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
End If

myFile = Dir$(PathToUse & "*.doc")

If Documents.Count > 0 Then 'close any open documents
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close Savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."
End Sub


Thank you very much for your help. I am getting an error message at
the line "Dim fDialog as FileDialog." The error says "Compile Error.
User-defined type not defined." Do you know why I'm getting an error
and how I can fix it?

Thanks.

Graham Mayor said:
You need something like

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog 'Pick folder containing the files
.Title = "Select Folder containing the documents to be modifed
and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
PathToUse = fDialog.SelectedItems.Item(1)
If Right(PathToUse, 1) <> "\" Then PathToUse = PathToUse + "\"
End With

If Documents.Count > 0 Then 'close any open documents
Documents.Close savechanges:=wdPromptToSaveChanges
End If

myFile = Dir$(PathToUse & "*.doc")

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
I need a macro that opens all of the word documents in specific
folder, extracts the document headings (what you see in the outline
view) and pastes all of the headings into a new document. I have a
macro that extracts the headings (see below).

The problem is, I have to run this macro on each file individually
and it puts the headings in a separate document for each file. I
would like to have one document with all of the headings from all of
the files, one right after each other. I've never been able to
figure out how to write macros that run through all the files in a
folder. If you have any suggestions, I would really appreciate your
help. Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
Click to expand...
Click to expand...
Click to expand...
 
J

jkmar5

Wow. This macro works like a dream. Thank you, thank you, thank you!

Graham Mayor said:
There should not be a period after FileDialog
If that doesn't fix it, use the following less elegant folder selection
routine

Sub PrintHeadings()
Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer

' Get the folder containing the files
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

'Close any documents that may be open
If Documents.Count > 0 Then
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

FirstLoop = True

If Left(PathToUse, 1) = Chr(34) Then
PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
End If

myFile = Dir$(PathToUse & "*.doc")

If Documents.Count > 0 Then 'close any open documents
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close Savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."
End Sub


Thank you very much for your help. I am getting an error message at
the line "Dim fDialog as FileDialog." The error says "Compile Error.
User-defined type not defined." Do you know why I'm getting an error
and how I can fix it?

Thanks.

Graham Mayor said:
You need something like

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog 'Pick folder containing the files
.Title = "Select Folder containing the documents to be modifed
and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
PathToUse = fDialog.SelectedItems.Item(1)
If Right(PathToUse, 1) <> "\" Then PathToUse = PathToUse + "\"
End With

If Documents.Count > 0 Then 'close any open documents
Documents.Close savechanges:=wdPromptToSaveChanges
End If

myFile = Dir$(PathToUse & "*.doc")

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web site www.gmayor.com

<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

jkmar5 wrote:
I need a macro that opens all of the word documents in specific
folder, extracts the document headings (what you see in the outline
view) and pastes all of the headings into a new document. I have a
macro that extracts the headings (see below).

The problem is, I have to run this macro on each file individually
and it puts the headings in a separate document for each file. I
would like to have one document with all of the headings from all of
the files, one right after each other. I've never been able to
figure out how to write macros that run through all the files in a
folder. If you have any suggestions, I would really appreciate your
help. Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
Click to expand...
Click to expand...
Click to expand...
 
G

Graham Mayor

You are welcome :)

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

Wow. This macro works like a dream. Thank you, thank you, thank you!

Graham Mayor said:
There should not be a period after FileDialog
If that doesn't fix it, use the following less elegant folder
selection routine

Sub PrintHeadings()
Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer

' Get the folder containing the files
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
PathToUse = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

'Close any documents that may be open
If Documents.Count > 0 Then
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

FirstLoop = True

If Left(PathToUse, 1) = Chr(34) Then
PathToUse = Mid(PathToUse, 2, Len(PathToUse) - 2)
End If

myFile = Dir$(PathToUse & "*.doc")

If Documents.Count > 0 Then 'close any open documents
Documents.Close Savechanges:=wdPromptToSaveChanges
End If

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close Savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."
End Sub


Thank you very much for your help. I am getting an error message at
the line "Dim fDialog as FileDialog." The error says "Compile Error.
User-defined type not defined." Do you know why I'm getting an error
and how I can fix it?

Thanks.

:

You need something like

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer
Dim myFile As String
Dim PathToUse As String
Dim MyDoc As Document
Dim iFld As Integer
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog 'Pick folder containing the files
.Title = "Select Folder containing the documents to be modifed
and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
PathToUse = fDialog.SelectedItems.Item(1)
If Right(PathToUse, 1) <> "\" Then PathToUse = PathToUse + "\"
End With

If Documents.Count > 0 Then 'close any open documents
Documents.Close savechanges:=wdPromptToSaveChanges
End If

myFile = Dir$(PathToUse & "*.doc")

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."
'Open the document to collect the data
Set DocB = Word.Documents.Add '(DocA.AttachedTemplate.name)
' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

While myFile <> ""
'open the document for processing
Set MyDoc = Documents.Open(PathToUse & myFile)
Set DocA = ActiveDocument

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0
' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
rng = Replace(rng, "^m", "")

DocA.Close savechanges:=wdDoNotSaveChanges
Set DocA = Nothing

GetNextDoc:
myFile = Dir$()
Wend
'Save target doc
DocB.Save
Set DocB = Nothing
' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web site www.gmayor.com

<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

jkmar5 wrote:
I need a macro that opens all of the word documents in specific
folder, extracts the document headings (what you see in the
outline view) and pastes all of the headings into a new document.
I have a macro that extracts the headings (see below).

The problem is, I have to run this macro on each file individually
and it puts the headings in a separate document for each file. I
would like to have one document with all of the headings from all
of the files, one right after each other. I've never been able to
figure out how to write macros that run through all the files in a
folder. If you have any suggestions, I would really appreciate
your help. Thank you.

Sub PrintHeadings()

' Creates a new document with Heading XX
' style paragraphs only from active document.
' User prompted for max level XX.

Dim para As Paragraph, rng As Range
Dim DocA As Document, DocB As Document
Dim iLevel As Integer, iMaxLevel As Integer

' Ask for max level
iMaxLevel = InputBox("Enter maximum level for Heading style.")
If iMaxLevel = 0 Then Exit Sub

StatusBar = "Printing headings. Please wait..."

Set DocA = ActiveDocument

' Create new document
Set DocB = Word.Documents.Add(DocA.AttachedTemplate.Name)

' Set extra wide page margins
With DocB.PageSetup
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
End With

Set rng = DocB.Range

For Each para In DocA.Paragraphs
DoEvents
iLevel = 0

' Check for Heading style
If para.Format.Style Like "Heading [0-9]" Then

iLevel = Val(Mid(para.Format.Style, 8))
' Check for acceptable level
If iLevel > 0 And iLevel <= iMaxLevel Then
rng.Collapse wdCollapseEnd
rng.Text = String(iLevel - 1, vbTab) & _
Format(iLevel) & ") " & para.Range.Text
End If

End If
Next para

' Delete any annoying page breaks
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute replace:=wdReplaceAll

' Tell user when done
MsgBox "Done creating new document with headings only."

End Sub
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Adding a Checkbox 1
Making a macro only work on certain files 2
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Bullet Styles Macro 0
Table of Content 1
Macro to fix header 0
Please help!!! No replies - Posting query again 0
Count the number of deleted manual page breaks 4

Top