从 Outlook vba 中的电子邮件正文获取电子邮件地址答案

【问题标题】：Get email address from email body in outlook vba从 Outlook vba 中的电子邮件正文获取电子邮件地址
【发布时间】：2020-06-26 15:34:19
【问题描述】：

我一直在研究一个宏来从特定文件夹中包含的电子邮件中获取电子邮件地址。

我能够进入该文件夹并获取其中的所有项目（电子邮件），虽然代码执行良好，提取了我需要的内容，但它在检索到大约 1273 个电子邮件地址时停止。

该文件夹包含大约 96,870 封电子邮件。我已经完成了我的逻辑并且我认为我没有错误，但它仍然没有完成所有的电子邮件。

这是我的代码：

Sub GetUndeliverables()
On Error Resume Next
    Dim olApp As Object
    Dim olMail As Outlook.MailItem
    Dim ns As Outlook.NameSpace
    Dim location As Outlook.MAPIFolder
    Dim xlApp As Excel.Application
    Dim text As String
    Dim i As Long
    Dim j As Long
    Dim regEx As Object
    Dim olMatches As Object
    Dim strBody As String
    Dim email As String
    Dim foldCount As Long
    Dim badEmails() As String

    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Accounts As Outlook.Accounts
    Dim currentAccount As Outlook.Account

    Set Session = Application.Session
    Set Accounts = Session.Accounts

    j = 1
    For Each currentAccount In Accounts
        If currentAccount.Session.Folders.Item(j).Name = "REDACTED" Then
            Set location = currentAccount.Session.Folders.Item(j)
        End If
        j = j + 1
    Next

    Set xlApp = CreateObject("Excel.Application")

    'Set ns = Application.GetNamespace("MAPI")

    Set location = location.Folders("Bandeja de entrada").Folders("Remover 2014")

    Set regEx = CreateObject("VBScript.RegExp")

    'set the regular expression
    With regEx
        .Pattern = "\b[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
        .IgnoreCase = True
        .MultiLine = True
        .Global = True
    End With

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox ("No item selected")
        Exit Sub
    End If

    If location Is Nothing Then
        MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Error"
    End If

    i = 1
    xlApp.Workbooks.Add
    xlApp.Application.Visible = True

    foldCount = location.Items.Count

    ReDim badEmails(1 To foldCount)

    For Each olMail In location.Items
        strBody = olMail.Body
        Set olMatches = regEx.Execute(strBody)
        If olMatches.Count >= 1 Then
            badEmails(i) = olMatches(o)
        End If
        xlApp.ActiveSheet.Cells(i, 1) = badEmails(i)
        i = i + 1
    Next

    Set olMail = Nothing
    Set location = Nothing
    Set ns = Nothing
End Sub

【问题讨论】：

你有On Error Resume Next 这不是抽奖中最锋利的工具，尝试调试你的代码。
使用@PaulFrancis 的建议并添加option Explicit on top，然后查看您遇到的错误
我已经设法将问题缩小到这样一个事实，即在一封电子邮件中，它出现在尖括号之间，这就是代码停止的时候。关于如何修改正则表达式来解决这个问题的任何想法？

标签： excel vba email outlook

【解决方案1】：

而不是遍历每个 Outlook 项目：

 For Each olMail In location.Items
    strBody = olMail.Body
    Set olMatches = regEx.Execute(strBody)

我建议使用 Items 类的 Find/FindNext 或 Restrict 方法。此外，您可能会发现 Application 类的 AdvancedSearch 方法很有帮助。

【讨论】：

【解决方案2】：

所以，我设法弄清楚了这一点：

当某些电子邮件被退回时，它们似乎没有包含 “收件人” 字段，因此 Outlook 不会认为 MailItem。

由于olMail 已被声明为Outlook.MailItem，因此在遍历Items 集合时，一旦发现此类事件，它将退出子。

要解决此问题，只需将 olMail 的类型更改为 Object

【讨论】：