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

Question

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

我能够进入该文件夹并获取其中的所有项目（电子邮件），虽然代码执行良好，提取了我需要的内容，但它在检索到的大约 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

Answer 1

而不是遍历每个 Outlook 项目：

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

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

Answer 2

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

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

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

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