microsoft.public.word.vba.general

You are welcome :)

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

My web site www.gmayor.com
Word MVP web site http://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>


jkmar5 wrote:
> Wow. This macro works like a dream. Thank you, thank you, thank you!
>
> "Graham Mayor" wrote:
>
>> 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
>>
>>
>>
>> jkmar5 wrote:
>>> 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" wrote:
>>>
>>>> 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
>>>> Word MVP web site http://word.mvps.org
>>>> <>>< ><<> ><<> <>>< ><<> <>>< <>><<>
>>>>
>>>> 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