我正在尝试扩展某些 Outlook 电子邮件报废 VBA 代码的功能。我会定期收到退回的电子邮件，并希望通过将所述电子邮件地址导出到 MS Excel 来跟踪这些（删除）。
代码在一定程度上有效。我只能使用 RegEx 抓取典型的退回通知电子邮件中的第一个电子邮件地址。我工作的公司的邮件服务器将来自同一域的电子邮件聚合到一封通知电子邮件中。因此，我收到了多封包含多封退回电子邮件的通知电子邮件。
如何让 RegEx 循环浏览整个通知电子邮件以收集所有电子邮件地址？？？我现在有点卡住了，因为——不可否认——我对 RegEx 了解不多，并且“采用”了这段代码的大部分......
感谢您对 Stackoverflow 的帮助！！！
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 中。