How to find text in multiples documents and copy results for a separeted document?

[danielbasilio]

Hi,
I find this macro bellow but it just work for 1 document. I wanted select many documents and execute it.
I printed how it Works to explain the code.

1-First command:

CopyKeywordPlusContext()

Then it ask what Im looking for. More 2 box open asking how many word before and after I need copy. So I type 10 before and 10 after “deste”.

Then showed this box:

I choose “sim” (yes) and finally the results:

The name of document, page and 10 words before and 10 after of the term “deste”.

Anyone can help me ?

Code:

Sub GoToAPageAndLine() '' Makro created on 22.01.2013
'
    Dim TargetDocName, SearchTerm, MyString As String, TargetDoc As Document
    Dim PosDelimiter, PosMakroButton, Page, Line
    'Read Private Field which contains The Document Name
    MyString = Mid$(Selection.Fields(2).Code, 10)
    MyString = Left$(MyString, Len(MyString) - 1)
    PosDelimiter = InStr(MyString, "|")
    TargetDocName = Left$(MyString, PosDelimiter - 1)
    SearchTerm = Mid$(MyString, PosDelimiter + 1)
    'MsgBox TargetDocName
    'Read the MakroButton Text which contains Page Number and Line
    MyString = Mid$(Selection.Fields(1).Code, 1)
    PosMakroButton = InStr(MyString, "MACROBUTTON")
    MyString = Mid$(MyString, PosMakroButton + 32)
    PosDelimiter = InStr(MyString, ", ")
    Page = Left$(MyString, PosDelimiter - 1)
    Line = Mid$(MyString, PosDelimiter + 4)
    'MsgBox Page
    'MsgBox Line
    On Error GoTo Errhandler
    Set TargetDoc = Documents(TargetDocName)
    TargetDoc.Activate
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Page, Name:=""
    If Line - 1 > 0 Then
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=Line - 1, Name:=""
    End If
    If SearchTerm <> "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = SearchTerm
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute
    End If
Errhandler:
    Select Case Err
        Case 4160: 'Error 4160 = Bad file name
            MsgBox "The file """ & TargetDocName & """ isn't open. Please open the file first."
    End Select
End Sub
Sub macrobutton(Page, Line As Integer, Filename, SearchTerm As String)
'
' Makro created on 22.01.2013
'
    Dim oField As Field, MyRange As Range
    Set MyRange = Selection.Range
    Set oField = Selection.Fields.Add(Range:=MyRange, Type:=wdFieldEmpty, Text:= _
        "MACROBUTTON GoToAPageAndLine S. " & Page & ", Z. " & Line & "", PreserveFormatting:= _
        False)
    Set oRange = ActiveDocument.Range(oField.Code.Start + 1, oField.Code.Start + 1)
    ActiveDocument.Fields.Add Range:=oRange, Type:=wdFieldPrivate, Text:="" & Filename & "|" & SearchTerm, PreserveFormatting:=False
End Sub
Sub CopyHighlightedTextInNewDocument()
'
' Makro created on 22.01.2013
'
    ActiveDocument.Range(0, 0).Select
    With Selection
        .Find.ClearFormatting
        .Find.Highlight = True
        With .Find
            .Replacement.ClearFormatting
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Set CurrentDoc = ActiveDocument
        Set NewDoc = Documents.Add(Visible:=False)
        NewDoc.Content.InsertAfter "Summary of the highlighted text in " & """" & CurrentDoc.Name & """"
        NewDoc.Content.Font.Bold = True
        NewDoc.Content.InsertParagraphAfter
        NewDoc.Content.InsertParagraphAfter
        .Find.Execute
        Dim PageNumber, LineNumber As Integer
        Do While .Find.Found
            .Select
            Selection.Copy
            PageNumber = .Information(wdActiveEndPageNumber)
            LineNumber = .Information(wdFirstCharacterLineNumber)
            NewDoc.Activate
            With Selection
              .EndKey Unit:=wdStory
              .Font.Bold = True
              .Font.Underline = True
              .Font.ColorIndex = wdDarkBlue
              Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, "")
              .Font.Bold = True
              .Font.Underline = False
              .Font.ColorIndex = wdBlack
              '.InsertAfter "S. " & PageNumber
              '.InsertAfter ", Z. " & LineNumber
              .TypeText "______________________________________________________________" & vbCr
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
              .Paste
              .InsertParagraphAfter
              .InsertParagraphAfter
              .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
            End With
            CurrentDoc.Activate
            .Find.Execute
        Loop
    End With
    NewDoc.Activate
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub
Sub CopyKeywordPlusContext()
'
' Makro created on 22.01.2013
'
    Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
    Dim Rng As Range, Doc As Document, RngOut As Range
    SearchTerm = InputBox("Enter your search terms, Maria Cancro!" & vbCr & _
      "Then, sit back, relax, and let this macro do some heavy lifting." & vbCr & _
      vbCr & "It's okay - it works out!")
    SearchTerm = LCase(Trim(SearchTerm))
    If Len(SearchTerm) = 0 Then Exit Sub
    WordsBefore = InputBox("Enter the number of words before your search term to find.")
    WordsAfter = InputBox("Enter the number of words after your search term to find.")
    ActiveDocument.Range(0, 0).Select
    With Selection
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = SearchTerm
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .Execute
      End With
      If .Find.Found Then
        Set CurrentDoc = ActiveDocument
        Set Doc = Documents.Add(Visible:=False)
        Doc.Content.InsertAfter "Search results for """ & SearchTerm & """ + context in " & """" & CurrentDoc.Name & """"
        Doc.Content.Font.Bold = True
        Doc.Content.InsertParagraphAfter
        Doc.Content.InsertParagraphAfter
        Dim CheckAuto As Integer
        CheckAuto = MsgBox("Should all findings be copied automatically ('yes') or do you want to check each occurence manually ('no') ?", vbYesNo, "Automatically oder manually?")
        Dim CopyThis As Boolean
        Do While .Find.Found
          CopyThis = False
          Set Rng = .Range.Duplicate
          With Rng
            .Select
            Dim SelectionStart, SelectionEnd
            SelectionStart = Selection.Range.Start
            SelectionEnd = Selection.Range.End
            ActiveDocument.Range(SelectionStart, SelectionStart).Select
            Dim PageNumber, LineNumber As Integer
            PageNumber = Selection.Information(wdActiveEndPageNumber)
            LineNumber = Selection.Information(wdFirstCharacterLineNumber)
            .MoveStart wdWord, -WordsBefore
            .MoveEnd wdWord, WordsAfter + 2
            .Select
            Selection.MoveStart Unit:=wdLine, Count:=-1 'Comment this out if you
            Selection.MoveEnd Unit:=wdLine, Count:=1    '                        don't want the selection to be extended to the start / end of line
            If CheckAuto = vbYes Then
                CopyThis = True
            Else
                Dim Check As Integer
                Check = MsgBox(.Text, vbYesNoCancel, "Copy this block?")
                If Check = vbCancel Then
                    Exit Do
                ElseIf Check = vbYes Then
                    CopyThis = True
                End If
            End If
            If CopyThis = True Then
              Selection.Copy
              Doc.Activate
              With Selection
                  .EndKey Unit:=wdStory
                  .Font.Bold = True
                  .Font.Underline = True
                  .Font.ColorIndex = wdDarkBlue
                  Call macrobutton(PageNumber, LineNumber, CurrentDoc.Name, SearchTerm)
                  .Font.Bold = True
                  .Font.Underline = False
                  .Font.ColorIndex = wdBlack
                  '.InsertAfter "S. " & PageNumber
                  '.InsertAfter ", Z. " & LineNumber
                  .TypeText "______________________________________________________________" & vbCr
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
                  .Paste
                  .InsertParagraphAfter
                  .InsertParagraphAfter
                  .MoveDown Unit:=wdLine, Count:=2, Extend:=wdMove
              End With
              CurrentDoc.Activate
            End If
          End With
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
        Doc.Activate
      End If
    End With
    With Doc.Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = SearchTerm
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    Options.ButtonFieldClicks = 1
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.Visible = True
End Sub