Question

我需要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

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中运行代码，则需要使用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。

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

2 个答案: