Как извлечь адрес электронной почты из документа Word с помощью vba

Question

Моя цель - извлечь все адреса электронной почты из Word.ActiveDocument и поместить их в одну ячейку на листе Excel.

Код запускается из редактора Excel VBA. Нужно искать адреса электронной почты, извлекать их из документа и заполнять ячейку Excel Activesheet.Range("C31"). Доступна только одна ячейка, независимо от того, сколько адресов электронной почты найдено.

Найденные адреса должны быть разделены с помощью ", " запятой и пробела.

Я пытаюсь Сделайте это, найдя в документе @, а затем увеличьте диапазон вперед и назад, чтобы все адреса электронной почты были в переменной диапазона. Построить адрес справа было довольно просто, используя rng.MoveEndUntil Cset:=",", потому что в моем документе после адреса электронной почты всегда есть кома.

Но как получить недостающую левую сторону адреса электронной почты в переменной диапазона? ? Я использовал rng.MoveStart Unit:=wdWord, Count:=-1, но что, если письмо будет romek. zjelonek@wp.com или grawer. best@yahoo.com Это не будет работать.

Это то, что у меня сейчас.

Sub FindEmail035()         '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
                           '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim ExcelApp As Excel.Application

Dim rng As Word.Range
Dim emailAdr As String
Dim ws As Worksheet

Set WordApp = GetObject(, "Word.Application")
Set ExcelApp = GetObject(, "Excel.Application")
Set WordDoc = WordApp.ActiveDocument
Set rng = WordApp.ActiveDocument.Content
Set ws = ExcelApp.ActiveSheet

ExcelApp.Application.Visible = True

    With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            'rng.Expand (wdWord)
            'Debug.Print rng.Text
            rng.MoveStart Unit:=wdWord, Count:=-1
            Debug.Print rng.Text
            rng.MoveEndUntil Cset:=","
            'rng.MoveEnd Unit:=wdWord, Count:=1
            'rng.MoveEndUntil Cset:=" ", Count:=wdBackward
        End If
   End With     'how to create loop that will extract all the email addresses in the document??
   ws.Range("C31").Value = rng

End Sub

Что l oop я должен использовать, чтобы получить количество писем, присутствующих в документе, а затем составить диапазоны с адресами электронной почты внутри?

Это место в документе, где находятся почтовые адреса.

Answer 1

Вы на правильном пути. Здесь проще всего переместить начало диапазона с помощью .MoveStartUntil Cset:=" " Count:=wdBackward, чтобы вы могли перемещаться назад по диапазону, пока не достигнете пробела перед адресом электронной почты. Это, конечно, предполагает последовательное форматирование и отсутствие произвольных пробелов.

Я бы также просто просматривал ActiveDocument.Content, а затем Set rng каждый раз .Found = True, потому что вы не хотите, чтобы он переопределял ваш диапазон (который это делает при поиске диапазона). Или Dim новый диапазон srchRng или что-то еще, а затем установите его для найденных результатов.

 With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            rng.MoveStartUntil Cset:=" ", Count:=wdBackward
            rng.MoveEndUntil Cset:=","
        End If

Answer 2

Предполагая, что адреса электронной почты являются открытым текстом, вы можете использовать код Word VBA, например:

Sub Demo()
Dim StrOut As String
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[0-9A-ÿ.\-]{1,}\@[0-9A-ÿ\-.]{1,}([^13 -/\:-\@\\-`\{-¿])"
    .Replacement.Text = ""
    .Forward = True
    .Format = False
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrOut = StrOut & Trim(.Text) & " "
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
StrOut = Replace(Trim(StrOut), " ", "; ")
MsgBox StrOut
End Sub