Regex VBA正则表达式在MS Outlook中抓取反弹的电子邮件

我正在尝试扩展某些Outlook电子邮件的功能，以消除VBA代码。我定期收到回复邮件，并希望通过将上述电子邮件地址导出到MS Excel来跟踪这些邮件（用于删除）

代码在一定程度上是有效的。我只能使用正则表达式在典型的回退通知电子邮件中刮取第一个电子邮件地址。我工作的公司的邮件服务器将来自同一域的电子邮件聚合为一封通知电子邮件。因此，我收到多封通知电子邮件，其中包含多封被退回的电子邮件

如何让RegEx在整个通知电子邮件中循环以收集所有电子邮件地址？？？我现在有点困惑，因为——诚然——我对RegEx了解不多，并且“采纳”了大部分代码

谢谢你的帮助

Sub Extract_Invalid_To_Excel()

Dim olApp As Outlook.Application
Dim olExp As Outlook.Explorer
Dim olFolder As Outlook.MAPIFolder
Dim obj As Object
Dim stremBody As String
Dim stremSubject As String
Dim i As Long
Dim x As Long
Dim count As Long
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
Dim xlApp As Object 'Excel.Application
Dim xlwkbk As Object 'Excel.Workbook
Dim xlwksht As Object 'Excel.Worksheet
Dim xlRng As Object 'Excel.Range

Set olApp = Outlook.Application
Set olExp = olApp.ActiveExplorer

Set olFolder = olExp.CurrentFolder

'Open Excel
Set xlApp = GetExcelApp
xlApp.Visible = True
If xlApp Is Nothing Then GoTo ExitProc

Set xlwkbk = xlApp.Workbooks.Add
Set xlwksht = xlwkbk.Sheets(1)
Set xlRng = xlwksht.Range("A1")
xlRng.Value = "Bounced email addresses"

'Set count of email objects
count = olFolder.Items.count

'counter for excel sheet
i = 0
'counter for emails
x = 1

For Each obj In olFolder.Items '**Loops through selected Outlook folder**
    xlApp.StatusBar = x & " of " & count & " emails completed"
    stremBody = obj.Body
    stremSubject = obj.Subject

    If checkEmail(stremBody) = True Then '**Checks email for keywords in email
        'MsgBox ("finding email: " & stremBody)

        '**RegEx to find email addresses within message body
        With RegEx
            .Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
            .IgnoreCase = True
            .MultiLine = True
            .Global = False
            Set olMatches = .Execute(stremBody) 'Executes RegEx function

            'Loop through RegEx matches
            For Each match In olMatches
                xlwksht.Cells(i + 2, 1).Value = match
                i = i + 1
            Next match
        End With
        'TODO: move or mark the email that had the address extracted
    Else
        '**To view the items that aren't being parsed uncomment the following line
        'MsgBox (stremBody)
    End If

    x = x + 1
Next obj
xlApp.ScreenUpdating = True
MsgBox ("Invalid Email addresses are done being extracted")

ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set emItm = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub

Function GetExcelApp() As Object
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0
End Function

Function checkEmail(ByVal Body As String) As Boolean
    Dim keywords(3) As String
    keywords(0) = "recipient's e-mail address was not found"
    keywords(1) = "error occurred while trying to deliver this message"
    keywords(2) = "message wasn't delivered"

    'Default value
    checkEmail = False
     For Each word In keywords
        If InStr(1, Body, word, vbTextCompare) > 1 Then
            checkEmail = True
            Exit For
        End If
     Next word
End Function

提供更多细节。我会收到数百封包含以下文字的电子邮件：

Delivery has failed to these recipients or distribution lists:

John.Doe@abc.com
The recipient's e-mail address was not found in the recipient's e-mail system. Microsoft Exchange will not try to redeliver this message for you. Please check the e-mail address and try resending this message, or provide the following diagnostic text to your system administrator.

Morgan.Freedman@abc.com
The recipient's e-mail address was not found in the recipient's e-mail system. Microsoft Exchange will not try to redeliver this message for you. Please check the e-mail address and try resending this message, or provide the following diagnostic text to your system administrator.

Michael.Jordan@abc.com
The recipient's e-mail address was not found in the recipient's e-mail system. Microsoft Exchange will not try to redeliver this message for you. Please check the e-mail address and try resending this message, or provide the following diagnostic text to your system administrator.

上面的代码能够获取电子邮件正文文本中的第一个电子邮件地址（即John）。Doe@abc.com)，但看不到其他两个电子邮件地址

---

代码的其余部分可以完美地工作。它将找到的电子邮件地址导出到Excel中。

虽然我对RegEx函数还不熟悉，但我还是盲目地对代码进行了轻微修改

我将RegEx.Global布尔值改为True，这段代码将完美地工作

With RegEx
   yadda yadda yadda
   .Global = True
End With

---

无论如何，谢谢你。希望这能帮助其他人

经过多次搜寻，我终于想出了以下功能。一些正文文本仍然包含无效字符（不知道为什么），但总的来说大约90%是正确的。此函数用于解析传递的Outlook Items集合，并将所有唯一的电子邮件地址（位于ReportItem正文中）添加到字符串列表中，该列表将写入末尾的即时窗口

Private Sub ListEmailAddresses(outlookItems As Outlook.Items)
  Dim folder As Outlook.MAPIFolder = Nothing
  Try
    Dim emailAddresses As New List(Of String)
    If TypeOf outlookItems.Parent Is Outlook.MAPIFolder Then
      folder = CType(outlookItems.Parent, Outlook.MAPIFolder)
    End If
    For i = 1 To outlookItems.Count
      Dim objItem As Object = outlookItems(i)
      Try
        If TypeOf objItem Is Outlook.ReportItem Then
          Dim rpt As Outlook.ReportItem = TryCast(objItem, Outlook.ReportItem)
          Dim temp() As Byte = System.Text.Encoding.Unicode.GetBytes(rpt.Body.ToArray())
          Dim sb As New System.Text.StringBuilder
          For z As Integer = 0 To temp.Length - 1
            sb.Append(Chr(temp(z)))
          Next
          Dim rptBody As String = sb.ToString
          Dim mc As MatchCollection = Regex.Matches(rptBody, _
                     "([a-zA-Z0-9_\-\.]+)@([a-zA-Z0-9_\-\.]+)\.([a-zA-Z]{2,5})")
          Dim results(mc.Count - 1) As String
          For x As Integer = 0 To results.Length - 1
            Dim emailAddr As String = ValueIfNull(mc(x).Value, "").ToLower
            If Not String.IsNullOrWhiteSpace(emailAddr) Then
              If Not emailAddresses.Contains(emailAddr) Then
                emailAddresses.Add(emailAddr)
              End If
            End If
          Next
        End If
      Catch ex As Exception
        ' Do Something if you care.
      Finally
        Marshal.ReleaseComObject(objItem)
      End Try
    Next
    emailAddresses.Sort()
    Debug.WriteLine(emailAddresses.ToSeparatedString(Environment.NewLine))
  Catch ex As Exception
    ' Do Something if you care.
  Finally
    If folder IsNot Nothing Then Marshal.ReleaseComObject(folder)
  End Try
End Sub

---

我收到多达200封被退回的电子邮件通知，每一封大型电子邮件都会被退回。通过不断联系，这很容易，因为该工具将所有跳转的地址和代码处理成一个漂亮的文件。有了Outlook，我只能靠自己了，但出于其他原因，我更喜欢它。 因此，我提出了一个程序和VBA宏来完成这项任务。首先，我将所有我希望处理的电子邮件放在一个文件夹中，并将其选中。使用Outlook 2010，我进入文件->选项->高级->导出。从那里我选择（下一步），然后选择最后一个选项，即制表符分隔值（窗口）。然后，选择名称和文件夹位置以存储一个TXT文件，该文件组合了文件夹中的所有电子邮件。 将文件打开到Msft Word并运行以下VBA宏：

Sub Bounced_Email_Harvester()
'
' Bounced-Email Text-Process Macro
'
Dim flag As Boolean
' DocLen is to maintain Document length in characters
Dim DocLen As Long
' Try to speed up Word by suspending unnecessary tasks
ActiveDocument.ActiveWindow.View.Draft = True
Options.Pagination = False
Options.CheckGrammarAsYouType = False
Options.CheckSpellingAsYouType = False
Application.ScreenUpdating = False
' Remove extraneous bracket characters < & >
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ">>>"
        .Replacement.Text = "###"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "<<<"
        .Replacement.Text = "VVV"
        .Forward = True
        .Wrap = wdFindContinue
    End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.WholeStory
DocLen = Len(Selection)
Application.DisplayStatusBar = True
Selection.HomeKey Unit:=wdStory
' CORE OF MACRO IS WITHIN THIS LOOP
Do While DocLen > 800
    ' Selects text until next @ sign is reached - locating email addresses
    flag = True
    While flag = True
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen - 1
        If Strings.Right(Selection.Range.Text, 1) = "@" Or DocLen < 2 Then flag = False
        Wend
    flag = True
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    DocLen = DocLen + 1
    While flag = True
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen + 1
    'Locate the Beginning of email seeking demarkations (brackets, space, tab, paragraph)
        If Strings.Right(Selection.Range.Text, 1) = "<" Or Strings.Right(Selection.Range.Text, 1) = "[" Or Strings.Right(Selection.Range.Text, 1) = "(" Or Strings.Right(Selection.Range.Text, 1) = " " _
        Or Strings.Right(Selection.Range.Text, 1) = Chr$(9) Or Strings.Right(Selection.Range.Text, 1) = Chr$(13) Or DocLen < 2 Then flag = False
    Wend
    Selection.TypeParagraph
    flag = True
    While flag = True
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen - 1
'Locate the End of email seeking demarkations (brackets, space, tab, paragraph)
        If Strings.Right(Selection.Range.Text, 1) = ">" Or Strings.Right(Selection.Range.Text, 1) = "]" Or Strings.Right(Selection.Range.Text, 1) = ")" Or Strings.Right(Selection.Range.Text, 1) = " " _
        Or Strings.Right(Selection.Range.Text, 1) = Chr$(9) Or Strings.Right(Selection.Range.Text, 1) = Chr$(13) Or DocLen < 2 Then flag = False
    Wend
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Previous(Unit:=wdCharacter, Count:=1).Select
    DocLen = DocLen + 1
    Selection.TypeParagraph
Loop
' END OF CORE MACRO LOOP
Selection.Collapse Direction:=wdCollapseEnd
    Selection.Previous(Unit:=wdCharacter, Count:=1).Select
    Selection.TypeParagraph
' Major work done - now some pesky house cleaning....
Selection.Find.ClearFormatting
With Selection.Find
    .Text = "mailto:"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = ":550^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = "<^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
    .Text = ";^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = "...^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = ".^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
MsgBox ("Count: " & DocLen)
End Sub

Sub-bounched\u Email\u Harvester（）
'
'反弹电子邮件文本处理宏
'
将标志变暗为布尔值
'DocLen用于以字符为单位保持文档长度
暗淡无光
“尝试通过暂停不必要的任务来加快Word的速度
ActiveDocument.ActiveWindow.View.Draft=True
Options.Pagination=False
Options.checkgrammarasyotype=False
Options.checkSpellingAsyOutType=False
Application.ScreenUpdating=False
'删除无关的括号字符<&>
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
选择。查找
.Text=“>>>”
.Replacement.Text=“####”
.Forward=True
.Wrap=wdFindContinue
以
Selection.Find.Execute Replace:=wdReplaceAll
选择。查找
.Text=“您所说的“整个通知电子邮件”是什么意思？您如何运行此代码？1）我直接在MS Outlook中运行此代码。然后，此代码将在导入正则表达式匹配项时打开Excel文件。2）“整个通知电子邮件”“是指在一封通知电子邮件中有多封被退回的电子邮件。我工作的公司的邮件服务器将来自同一域的电子邮件聚合为一封通知电子邮件。因此，我收到多封通知电子邮件，其中包含多封被退回的电子邮件。要对此进行扩展。。。来自（例如）yahoo的所有电子邮件都被分组为一封通知电子邮件（即在一封电子邮件中的列表中）。您可以使用“立即运行规则”在文件夹中运行代码。这不是一个简单的Outlook“规则”设置。。。我不知道你指的是什么。这是一个利用正则表达式的VBA程序。您可以将VBA代码或函数添加到outlook中，并可以使用“设置规则”或“立即运行规则”运行。由于某种原因，上面的代码以问号（“？”）和四（“4”）的组合形式生成所有文本，从而开始失败。我发现Outlook如何读取邮件/报表正文存在问题。要解决此问题，您需要将文本转换为unicode文本。。。[code]stremBody=obj.body stremSubject=obj.Subject'将文本转换为Unicode（可读）代码stremBody=StrConv（stremBody，vbUnicode）[code}