Word Макрос: Как найти абзац с email

[Svetik]

Здравствуйте!
Подскажите пожалуйста, как можно найти абзацы, в которых содержится "@mail.ru".
Нужно искать во всём файле (включая сноски) и в выделенном фрагменте.
И хотелось бы абзац как-то выделить, желтым цветом, например.

[Администратор]

Поиск во всей основной части файла и в сносках (страничных и концевых):

Макрос

Sub Макрос()

    Dim rng As Range, Found(1 To 3) As Boolean
    Dim var, i As Long
   
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Поиск в основной части файла.
    MyFind ActiveDocument.Range(0, 0), Found(1)
   
    '2. Поиск в страничных сносках.
    If ActiveDocument.Footnotes.Count <> 0 Then
        Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
        rng.Collapse Direction:=wdCollapseStart
        MyFind rng, Found(2)
    End If
   
    '3. Поиск в концевых сносках.
    If ActiveDocument.Endnotes.Count <> 0 Then
        Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
        rng.Collapse Direction:=wdCollapseStart
        MyFind rng, Found(3)
    End If
   
    '4. Включение монитора.
    Application.ScreenUpdating = True
   
    '5. Сообщение.
    If Found(1) = True Then
        var = "в основном тексте" & vbCr
    End If
    If Found(2) = True Then
        var = var & "в страничных сносках" & vbCr
    End If
    If Found(3) = True Then
        var = var & "в концевых сносках"
    End If
    If var <> "" Then
        MsgBox "Найдено здесь:" & vbCr & vbCr & var, vbInformation
    Else
        MsgBox "Не найдено.", vbInformation
    End If
   
End Sub

Sub MyFind(find_rng As Range, Found As Boolean)
   
    Dim find As find
   
   
    '1. Создание объекта для поиска.
    Set find = find_rng.find
   
    '2. Настройка поиска.
    find.text = "@mail.ru"
    find.Wrap = wdFindStop
   
    '3. Поиск и замена.
    Do While find.Execute = True
        ' Закраска абзаца.
        find_rng.Paragraphs(1).Range.Shading.BackgroundPatternColor = 65535
        ' Смещение невидимого курсора вправо от найденного абзаца, чтобы поиск
            ' начался после найденного абзаца, а не в найденном фрагменте.
        find_rng.SetRange find_rng.Paragraphs(1).Range.End, find_rng.Paragraphs(1).Range.End
        ' Пометка, что было найдено.
        Found = True
    Loop
   
End Sub

[свернуть]

Поиск в выделенном фрагменте:

Макрос

Sub Макрос()
   
    Dim find_rng As Range, find As find, SelEnd As Long
   
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Запоминание конца выделения.
    SelEnd = Selection.Range.End
   
    '3. Создание объектов для поиска.
    Set find_rng = Selection.Range.Duplicate
    find_rng.Collapse Direction:=wdCollapseStart
    Set find = find_rng.find
   
    '4. Настройка поиска.
    find.text = "@mail.ru"
    find.Wrap = wdFindStop
   
    '5. Поиск и замена.
    Do While find.Execute = True
   
        ' Если найдено за пределами выделенного фрагмента.
        If find_rng.End > SelEnd Then
            Exit Do
        End If
       
        ' Закраска абзаца.
        find_rng.Paragraphs(1).Range.Shading.BackgroundPatternColor = 65535
       
        ' Смещение невидимого курсора вправо от найденного абзаца, чтобы поиск
            ' начался после найденного абзаца, а не в найденном фрагменте.
        find_rng.SetRange find_rng.Paragraphs(1).Range.End, find_rng.Paragraphs(1).Range.End
       
    Loop
   
    '6. Включение монитора.
    Application.ScreenUpdating = True

End Sub

[свернуть]

[Svetik]

У меня все получилось, очень удобно.
Большое Вам спасибо!!!