如何从所有打开的 Word 文档中提取粗体文本的实例

Question

您好，以下代码从活动 Word 文档中提取所有粗体文本实例，并将其复制到新创建的 Word 文档中。

谁能帮我调整代码以对所有打开的 Word 文档执行相同的任务到新创建的 Word 文档中。

非常感谢任何帮助。

Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
     Dim ThisDoc As Document
     Dim ThatDoc As Document
     Dim r As Range
     Set ThisDoc = ActiveDocument
     Set r = ThisDoc.Range
     Set ThatDoc = Documents.Add
     
     With r
         With .Find
             .Text = ""
             .Format = True
             .Font.Bold = True
         End With
         Do While .Find.Execute(Forward:=True) = True
            'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
            If r.Bold Then
               ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
               ThatDoc.Range.InsertParagraphAfter
               .Collapse 0
            End If
          Loop
     End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub

Answer 1

您可以使用 Documents-collection 返回所有打开的文档：

Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
     Dim ThisDoc As Document
     Dim ThatDoc As Document
     Dim r As Range
     
     Set ThatDoc = Documents.Add

     'iterate over all open word documents
     'For Each ThisDoc In Application.Documents

      'handle documents in the order they were opened
      'reverse order of documents collection
      'loop until second to last as last one is ThatDoc


      Dim i As Long
      
      Dim FileNames As String, fFound As Boolean
      Dim fWritten As Boolean
      
      For i = Application.Documents.Count To 2 Step -1
        Set ThisDoc = Application.Documents(i)
        
        'Don't check document where the code runs
        If Not ThisDoc Is ThisDocument Then
        
    
            Set r = ThisDoc.Range
            
            With r
                With .Find
                    .Text = ""
                    .Format = True
                    .Font.Bold = True
                End With
                
                Do While .Find.Execute(Forward:=True) = True
                
                    '<-- remove this part if not needed
                    
                    'add filename if the first bold range
                    If fWritten = False Then
                        ThatDoc.Content.InsertAfter vbCrLf & vbCrLf & ThisDoc.Name & vbCrLf
                    End If
                    'remove this part if not needed -->
                    
                    fWritten = True
                    
                   'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
                   If r.Bold Then
                      ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
                      ThatDoc.Range.InsertParagraphAfter
                      .Collapse 0
                   End If
                 Loop
                 
            End With
            
            'add filename to list only if bold has been found
            If fWritten = True Then
                FileNames = FileNames & vbCrLf & ThisDoc.Name
                fWritten = False
            End If
        End If
    Next

'Add list of filenames to the end of ThatDoc
With ThatDoc.Content
    .InsertParagraphAfter
    .InsertAfter FileNames
End With
    
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub