Extract character styles into new document

[caveatRob]

Hi all,

I'm trying to extract text with particular character styles into a new
document. I've tried the following code, and it just runs an endless
loop:

Sub CollectCustomTopics()
' highlight parts of speech in a particular color then count the
number of lines in the new document!

Dim NewDoc As Document, MainDoc As Document, r As Range


If Documents.count = 0 Then Exit Sub
Set MainDoc = ActiveDocument
Set NewDoc = Documents.Add
MainDoc.Activate
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Highlight = True

Do While .Execute
DoEvents

Set r = NewDoc.Range
r.Collapse wdCollapseEnd
Select Case Selection.Style

Case "Topic Level 1"

r.InsertAfter "Topic Level 1"
'r.ParagraphFormat.LeftIndent = 18


Case "Topic Level 2"
r.InsertAfter "Topic Level 2"
Case "Topic Level 3"
r.InsertAfter "Topic Level 3"
Case "Topic Level 4"
r.InsertAfter "Topic Level 4"
Case "Topic Level 5"
r.InsertAfter "Topic Level 5"
Case "Topic Level 6"
r.InsertAfter "Topic Level 6"
End Select

r.InsertAfter Selection.Range.FormattedText
If Selection.Characters.Last.Text <> vbCr Then _
r.InsertAfter vbCr

Loop
End With
NewDoc.Activate
End Sub

 

[Helmut Weber]

Hi Rob,

at a long shot,
as setting up such styles and an according document
is too much for me right now.

Try to define the selection anew
before the end of your loop.

Sub CollectCustomTopics() [snip]
With Selection.Find
.Highlight = True
Do While .Execute
Set r = NewDoc.Range
r.Collapse wdCollapseEnd
Select Case Selection.Style
Case "Topic Level 1"
r.InsertAfter "Topic Level 1"

[snip]
selection.start = selection.end
selection.end = activedocument.range.end

Loop
End With
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP