Word VBA копирует выделенный текст в новый документ и сохраняет форматирование

Question

У меня есть документ с несколькими выделенными словами, которые я хочу скопировать в другой файл слов. Код, который я использую, работает нормально, но не сохраняет исходное форматирование в исходном документе. Вот весь код (первая секция находит слова, используя символы и подсвечивает их, а вторая секция находит выделенные слова и копирует их в новый текстовый документ):

Sub testcopytonewdoc2() 
' 
Dim ThisDoc As Document 
Dim ThatDoc As Document 
Dim r, newr, destr As Range 
Dim rangestart, rangeend As Long 

Set r = ActiveDocument.Range 
rangeend = r.Characters.Count 

r.Find.Execute FindText:="39.13 [Amended]" 
rangestart = r.Start 

'find words and highlight them 
x = 0 
Do While x < 4 
Application.ScreenUpdating = False 
Options.DefaultHighlightColorIndex = wdYellow 
With ActiveDocument.Content.Find 
    '.ClearFormatting 
    If x = 0 Then 
    .text = "[!)][(][1-9][)]?{7}" 
    ElseIf x = 1 Then 
    .text = "[!?][(][a-z][)][ ][A-Z]?{6}" 
    ElseIf x = 2 Then 
    .text = "[!?][(][ivx]{2}[)][ ][A-Z]?{6}" 
    Else 
    .text = "[!?][(][ivx]{3}[)][ ][A-Z]?{6}" 
    End If 
    With .Replacement 
    ' .ClearFormatting 
    .Highlight = True 
    End With 
    .Forward = True 
    .Wrap = wdFindContinue 
    .Format = True 
    .MatchWildcards = True 
    .Execute Replace:=wdReplaceAll 
End With 
Application.ScreenUpdating = True 
x = x + 1 
Loop 

Set ThisDoc = ActiveDocument 
Set newr = ThisDoc.Range 
Set ThatDoc = Documents.Add 

newr.SetRange Start:=rangestart, End:=rangeend 

'find highlighted words and add to a new document (preserve BOLD font): 

With newr.Find 
.text = "" 
.Highlight = True 
.Format = True 
.Wrap = wdFindStop 
    While .Execute 
    Set destr = ThatDoc.Range 
    destr.Collapse wdCollapseEnd 
    destr.FormattedText = newr.FormattedText 
    ThatDoc.Range.InsertParagraphAfter 
    newr.Collapse wdCollapseEnd 
    Wend 
End With 
Application.ScreenUpdating = True 

End Sub 

Может кто-нибудь помочь? Выделенные слова представляют собой сочетание жирного и полужирного текста, и важно сохранить эту разницу. Заранее спасибо за вашу помощь!

Холли

Answer 1

Попробуйте это так.

Sub ExtractHighlightedText() 

    Dim oDoc As Document 
    Dim s As String 
    With Selection 
     .HomeKey Unit:=wdStory 
With .Find 
      .ClearFormatting 
      .Text = "" 
      .Highlight = True 
      Do While .Execute 
       s = s & Selection.Text & vbCrLf 
      Loop 
     End With 
    End With 
Set oDoc = Documents.Add 
oDoc.Range.InsertAfter s 

End Sub 

Это происходит из моей книги.

http://www.lulu.com/shop/ryan-shuell/ebook/product-22936385.html