Как извлечь неизвестное количество адресов электронной почты / всех адресов электронной почты из документа Word, используя VBA

Question

Это продолжение для этого вопроса, и экран печати, встроенный в него с видом документа, по-прежнему применяется. Код запускается из редактора Excel VBA.

В документе Word неизвестное количество адресов электронной почты:

1. Мне нужно извлечь все из них,

2. объединить в одну строку, содержащую все адреса электронной почты, разделенные с помощью ", "

3. и заполнить строку в ячейке Excel Activesheet.Range("C31")

В настоящее время у меня есть код, который находит знак @ и строит вокруг него адрес электронной почты. Вот как это выглядит:

Sub FindEmail036()         '[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
Dim iCount As Integer

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 = wdFindContinue
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            rng.MoveStartUntil Cset:=" ", Count:=wdBackward
            Debug.Print rng.Text
            rng.MoveEndUntil Cset:=","
            Debug.Print rng.Text
            '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

Этот код извлекает только первый адрес электронной почты и не ищет следующие адреса электронной почты. Я знаю это, потому что я отлаживаю, используя F8 и окно Immediate, и я вижу, что этот код просто завершает поиск после того, как находит @ и создает первый полный адрес электронной почты.

Я думаю, что некоторые l oop необходимо, но я не знаю, как это сделать.

Я также нашел этот источник, но я не очень много понимаю из него. https://wordmvp.com/FAQs/MacrosVBA/NoTimesTextInDoc.htm

Answer 1

Я уже эффективно ответил на это в вашей другой ветке:

Sub Demo()
Dim wdApp As Word.Application, StrOut As String
Set wdApp = GetObject(, "Word.Application")
With wdApp.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), " ", ", ")
ActiveSheet.Range("C31").Value = StrOut
End Sub

Обратите внимание, как мало отличается этот код от кода, который я разместил в другой вашей ветке.

Answer 2

Это заканчивается, потому что способ Range.Find состоит в том, что он устанавливает диапазон, равный тому, что он находит. Таким образом, он находит @, устанавливает диапазон, равный ему, и теперь в нем больше нет @. Вам нужен другой диапазон для манипуляции, потому что манипулирование вашим диапазоном поиска только испортит ваши результаты.

Вы можете l oop с помощью Do While .Found = True (мой предпочтительный метод). Убедитесь, что вы установили .Wrap = wdFindStop, или у вас будет бесконечное число l oop.

Я бы поместил результаты в словарь.

Dim eAddresses As Object: Set eAddresses = CreateObject("Scripting.Dictionary")

Dim rng As Range
Set rng = ActiveDocument.Content
Dim srchRng As Range

Dim addressNum As Long
addressNum = 1

With rng.Find
        .Text = "@"
        .Wrap = wdFindStop
        .Forward = True
        .MatchWildcards = False
        .Execute
        Debug.Print rng.Text
        Do While .Found

            Set srchRng = rng.Duplicate
            srchRng.MoveStartUntil Cset:=" ", Count:=wdBackward
            Debug.Print srchRng.Text
            srchRng.MoveEndUntil Cset:=","

            If Not eAddresses.Exists(srchRng.Text) Then
                eAddresses.Add srchRng.Text, addressNum
                addressNum = addressNum + 1
            End If
            .Execute
        Loop
    End With

End Sub

В качестве примечания, когда Вы делаете эти 1017 * на производстве, я бы определенно вытащил все заявления Debug.Print. Это создает загроможденное непосредственное окно, особенно если вы планируете печатать полезные метрики и / или ошибки в прямом окне (что я рекомендую).

Answer 3

Другие респонденты определили причину вашей проблемы, поэтому я не буду повторять это. Тем не менее, ваше требование является общим шаблоном в VBA / Word, а именно найти что-то, а затем сделать что-то в результате поиска (кроме замены). Обычно я заключаю этот шаблон в функцию или подпрограмму в зависимости от того, какое действие необходимо выполнить после того, как будет найден текст поиска.

Если вы не использовали файл scripting.dictionary раньше, чем я использовал бы раннее связывание (как в приведенном ниже коде), так что вы получите доступ к intellisense для методов и свойств. Это означает использование Tools.Reference для добавления библиотеки Microsoft Scripting.Runtime в VBIDE.

Вы увидите, что мы пересчитываем конец документа каждый раз, когда мы проходим через While l oop. Это хорошая практика, потому что мы заранее не знаем, какое влияние окажут действия поиска на длину документа.

DoEvents в while l oop гарантирует, что вы сможете быстро выйти из Я oop, если вещи go не так.

Приведенная ниже функция использует поиск по шаблону Word для поиска адресов электронной почты. Находка является точной, поэтому нет необходимости настраивать концы найденного диапазона, чтобы получить только адрес электронной почты.

Если действие в найденном до l oop было сложным, то я бы разбил это на отдельная функция, передающая найденный диапазон функции как .Duplicate. В этом конкретном случае это также означало бы, что я бы переместил словарь сценариев из локальной переменной в переменную области видимости модуля

Public Function GetEmailAddressesAsString(ByVal ipDoc As Word.Document) As String

    Const EmailAddress As String = "<[0-9A-Za-z._]{1,}\@[0-9A-Za-z.\_]{1,}>"

    With ipDoc.StoryRanges(wdMainTextStory)

        With .Find

            .ClearFormatting
            .Wrap = wdFindStop
            .MatchWildcards = True
            .text = EmailAddress

        End With

        Dim myAddresses As Scripting.Dictionary
        Set myAddresses = New Scripting.Dictionary

        Do While .Find.Execute

            DoEvents
            myAddresses.Add myAddresses.Count, .text
            .MoveStart Count:=.Characters.Count + 1
            .End = ipDoc.StoryRanges(wdMainTextStory).End

        Loop

    End With

    GetEmailAddressesAsString = Join(myAddresses.Items, ",")

End Function

Answer 4

Я рекомендую использовать регулярные выражения.

Проверка Ссылка: Регулярные выражения Microsoft VBscript XX

Sub FindEmail()
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim ExcelApp As Excel.Application

    Dim StrInput As String, sPattern As String
    Dim oEmail As MatchCollection
    Dim Ws As Worksheet
    Dim vR()
    Dim n As Long, i As Long

    Set WordApp = GetObject(, "Word.Application")
    Set ExcelApp = GetObject(, "Excel.Application")
    Set WordDoc = WordApp.ActiveDocument

    StrInput = WordDoc.Content
    Set Ws = ExcelApp.ActiveSheet

    sPattern = "([A-z0-9.]{1,})(@)([A-z0-9]{0,})(.)([A-z0-9]{1,})"

    Set oEmail = GetRegEx(StrInput, sPattern)
    For i = 0 To oEmail.Count - 1
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = oEmail.Item(i)
    Next
    'Ws.Range("c31").Resize(n) = WorksheetFunction.Transpose(vR)
    Ws.Range("c31") = Join(vR, ", ") '<~~ single string
End Sub
Function GetRegEx(StrInput As String, strPattern As String) As Object
    Dim RegEx As New RegExp
    Set RegEx = New RegExp
    With RegEx
        .Global = True
        .IgnoreCase = False
        .MultiLine = True
        .Pattern = strPattern
    End With
    If RegEx.Test(StrInput) Then
        Set GetRegEx = RegEx.Execute(StrInput)
    End If
End Function

Ваш текстовый документ состоит из нескольких строк, поэтому я установил mutiline = true в настройке регулярного выражения. Поэтому регулярное выражение хранит все свое содержимое в matchcollection. Поместите этот сохраненный элемент в массив Dynami c и сделайте следующее. Вы можете сохранить массив в нескольких ячейках или создать один символ, используя функцию соединения.