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

Question

我需要 Outlook 中的宏来提取 outlook 邮件中的所有电子邮件地址，然后 post 它在 excel 中。

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

我想要的输出应该是：

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

我的示例电子邮件是：

Delivery has failed to these recipients or groups:

adam.peters@sample.com The e-mail address you entered couldn't be found. Please check the recipient's e-mail address and try to resend the message. If the problem continues, please contact your helpdesk.

adam.dryburgh@sample.com The e-mail address you entered couldn't be found. Please check the recipient's e-mail address and try to resend the message. If the problem continues, please contact your helpdesk.

amy.norton@sample.com The e-mail address you entered couldn't be found. Please check the recipient's e-mail address and try to resend the message. If the problem continues, please contact your helpdesk.

The following organization rejected your message: 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

Answer 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

Answer 2

我注意到下面一行代码：

Set olApp = Outlook.Application

如果您运行 Outlook 中的代码，您需要使用应用程序属性来获取应用程序class 的实例。或者您需要使用 New 运算符创建一个新实例，例如：

 Set ol = New Outlook.Application

或

 Set objOL = CreateObject("Outlook.Application")

有关详细信息，请参阅 How to automate Outlook from another program。

您也可以考虑使用 Word 对象模型来处理项目正文。 WordEditor property of the Inspector class returns an instance of the Document class which represents the message body. See Chapter 17: Working with Item Bodies了解更多信息。

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

Extract multiple email in a single Outlook message to Excel?

regex

excel

outlook

vba