MS Word VBA 查找单词周围的文本

Question

I'd like find text in Microsoft Word and get adjacent words.

I would like to start with a word and find all the words before and after they surround it.

The function should be recursive.

For Example:

abc def ghi jkl mno def pqr stu wxy def

if i search the string "def", the function should return me:

abc def ghi mno def pqr wxy def

it's possible?

thank you!

Sub Cerca(Parola)

Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim Prima As Integer
Dim Dopo As Integer

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting

 With Selection.Find
     .Text = Parola
    ' .Replacement.Text = "Provo"
     .Forward = True
     .Wrap = wdFindStop
     Do While .Execute() = True

         Selection.MoveRight Unit:=wdWord, Count:=4
         Set rng2 = Selection.Range

         Selection.MoveLeft Unit:=wdWord, Count:=9
         Set rng1 = Selection.Range

         Prima = rng1.Start
         Dopo = rng2.Start


         Set rngFound = ActiveDocument.Range(Prima, Dopo)
         strTheText = rngFound.Text
         ScriviFile Parola & Chr(9) & strTheText
         'Selection.Find.Replacement.Font.Italic = True
         'Selection.Font.Bold = True
         'Selection.MoveRight Unit:=wdCharacter, Count:=Dopo
        ' Selection.MoveRight Unit:=wdWord, Count:=1
        Selection.MoveRight Unit:=wdWord, Count:=9

     Loop
 End With
End Sub

The procedure I published does not work well because it also considers punctuation as words.

I try to explain myself better... i'd like a function that search in a Microsoft Word document a string and get me a number "x" of words before and next the string i have passed. For Example....

function myGetMyListOfSearch(SearchString as string, PreviusWord as integer, NextWord as integer)

This function return me a list of "strings" with my "SearchString" surrounded by the terms on the left and right of it...

it's possible?

Answer 1

A wildcard Find with:

Find = <[! ]@>[,. ^t^l^13]@Parola[,. ^t^l^13]@<[! ]@>

should suffice, even where the preceding/next word is in a different paragraph.

Answer 2

I am not proud of this solution ....

I look for a string in a word document and publish the result in a table of another word document ... The table is divided into 3 parts: in the center the string I searched for, in the first column "x number of words" to the left of the string and in the third column "y number of words" to the right of the searched string. But it's very slow ... better solutions? Thank you

Sub Cerca(Parola, Destinazione)

Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim Prima As Long
Dim Dopo As Long
Dim PosizioneAttuale As Long
Dim strSinistra As String
Dim strCentro As String
Dim strDestra As String
Dim UltimaRiga As Long
Dim Ciclo As Long
Dim Sicurezza As Long

Selection.HomeKey Unit:=wdStory
'Selection.Find.ClearFormatting

 With Selection.Find
     .Text = Parola
    ' .Replacement.Text = "Provo"
     .Forward = True
     .Wrap = wdFindStop
     .IgnorePunct = True
     .MatchWholeWord = ParoleIntere
     .ClearFormatting
     .Format = False
     Do While .Execute() = True

         DoEvents

         PosizioneAttuale = Selection.Start


         'SI CONTROLLA A DESTRA
         Ciclo = 0
         Sicurezza = 0
         Do
            'DoEvents
            Sicurezza = Sicurezza + 1
            Selection.MoveRight Unit:=wdWord, Count:=1
            If InStr(1, ".,;:-_/!\'()" & Chr(34) & vbCrLf, Trim(Selection.Range.Words.Item(1)), vbTextCompare) = 0 Then
                Ciclo = Ciclo + 1
            End If
            If Sicurezza > 100 Then
                'Debug.Print "esco con exit do"
                'Selection.MoveLeft Unit:=wdWord, Count:=501
                Exit Do 'nel caso entri in loop per qualche motivo
            End If
         Loop Until Ciclo = ParoleDopo Or Selection.Range.Start = ActiveDocument.Range.End

         Selection.MoveRight Unit:=wdWord, Count:=1
         Set rng2 = Selection.Range

         Selection.Start = PosizioneAttuale


         'SI CONTROLLA A SINISTRA

         Ciclo = 0
         Sicurezza = 0
         Selection.MoveLeft Unit:=wdWord, Count:=1
         Do
            'DoEvents
            Sicurezza = Sicurezza + 1
            Selection.MoveLeft Unit:=wdWord, Count:=1
            If InStr(1, ".,;:-_/!\'()", Trim(Selection.Range.Words.Item(1)), vbTextCompare) = 0 Then
                Ciclo = Ciclo + 1
            End If
            If Sicurezza > 100 Then
                Debug.Print "esco con exit do"
                'Selection.MoveRight Unit:=wdWord, Count:=501
                Exit Do 'nel caso entri in loop per qualche motivo
            End If
         Loop Until Ciclo = ParolePrima Or Selection.Range.Start = ActiveDocument.Range.End



         'Selection.MoveLeft Unit:=wdWord, Count:=ParolePrima + 1
         Set rng1 = Selection.Range

         Prima = rng1.Start
         Dopo = rng2.Start

         If Dopo > Prima Then
                 Set rngFound = ActiveDocument.Range(Prima, Dopo)

                 strTheText = rngFound.Text



                 'ScriviFile Left(strTheText, Prima) & Chr(9) & Parola & Chr(9) & Mid(strTheText, Dopo)
                 strSinistra = Left(strTheText, PosizioneAttuale - Prima)
                 strCentro = Parola
                 Prima = PosizioneAttuale + Len(Parola)
                 If Prima = -1 Then Prima = 0
                 strDestra = Right(strTheText, Dopo - Prima)


                 Selection.Start = PosizioneAttuale
                 Selection.MoveRight Unit:=wdWord, Count:=1

                 'scrivo nella tabella del foglio destinazione
                  Documents(Destinazione).Tables(1).Rows.Add
                  UltimaRiga = Documents(Destinazione).Tables(1).Rows.Count
                      Documents(Destinazione).Tables(1).Cell(UltimaRiga, 1).Range.InsertAfter strSinistra
                      Documents(Destinazione).Tables(1).Cell(UltimaRiga, 2).Range.InsertAfter strCentro
                      Documents(Destinazione).Tables(1).Cell(UltimaRiga, 3).Range.InsertAfter strDestra



         End If

     Loop
 End With
End Sub