将单个 Outlook 邮件中的多封电子邮件提取到 Excel？答案

【问题标题】：Extract multiple email in a single Outlook message to Excel?将单个 Outlook 邮件中的多封电子邮件提取到 Excel？
【发布时间】：2015-04-29 18:41:56
【问题描述】：

我需要 Outlook 中的宏来提取 Outlook 消息中的所有电子邮件地址，然后将其发布到 excel 中。

以下代码仅提取它在正文中找到的第一个电子邮件地址。

我想要的输出应该是：

adam.peters@sample.com
adam.dryburgh@sample.com
amy.norton@sample.com

我的示例电子邮件是：

向这些收件人或组发送失败：

adam.peters@sample.com 您输入的电子邮件地址不能是成立。请检查收件人的电子邮件地址并尝试重新发送消息。如果问题仍然存在，请联系您的帮助台。

adam.dryburgh@sample.com 您输入的电子邮件地址不能是成立。请检查收件人的电子邮件地址并尝试重新发送消息。如果问题仍然存在，请联系您的帮助台。

amy.norton@sample.com 您输入的电子邮件地址不能是成立。请检查收件人的电子邮件地址并尝试重新发送消息。如果问题仍然存在，请联系您的帮助台。

以下组织拒绝了您的邮件： mx2.dlapiper.iphmx.com.

代码：

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
    xlApp.StatusBar = x & " of " & count & " emails completed"
  stremBody = obj.Body
  stremSubject = obj.Subject

    'Check for keywords in email before extracting address
    If checkEmail(stremBody) = True Then
        'MsgBox ("finding email: " & stremBody)
        RegEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
        RegEx.IgnoreCase = True
        RegEx.MultiLine = True
        Set olMatches = RegEx.Execute(stremBody)
        For Each match In olMatches
            xlwksht.cells(i + 2, 1).Value = match
            i = i + 1
        Next match
        '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

【问题讨论】：

添加RegEx.Global = True
这是一封带有该正文的普通电子邮件吗？还是 NDR (ReportItem)？
它是 NDR。宏应该获取所有电子邮件发送失败的电子邮件地址的列表。我的解决方案是从 NDR 中提取电子邮件地址。您知道其他解决方案吗？

标签： regex excel outlook vba

【解决方案1】：

未经测试

替换

RegEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
RegEx.IgnoreCase = True
RegEx.MultiLine = True

与

 RegEx.Pattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
 RegEx.IgnoreCase = True
 RegEx.MultiLine = True
 RegEx.Global = True

【讨论】：

【解决方案2】：

我注意到下面这行代码：

Set olApp = Outlook.Application

如果您在 Outlook 中运行代码，则需要使用 Application 属性来获取 Application 类的实例。或者你需要使用 New 操作符来创建一个新的实例，例如：

 Set ol = New Outlook.Application

或

 Set objOL = CreateObject("Outlook.Application")

更多信息请参见How to automate Outlook from another program。

您也可以考虑使用 Word 对象模型来处理项目主体。 Inspector 类的WordEditor 属性返回一个表示消息正文的 Document 类的实例。请参阅Chapter 17: Working with Item Bodies 了解更多信息。

【讨论】：