从 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)

我建议使用应用程序 Find/FindNext or Restrict methods of the Items class. Also you may find the AdvancedSearch 的方法 class 很有帮助。

Answer 2

所以，我设法解决了这个问题：

当一些邮件退回时，它们似乎没有包含 "To" 字段，因此 Outlook 不认为 MailItem.

由于 olMail 已被声明为 Outlook.MailItem，因此在遍历 Items 集合时，一旦发现这样的事件，它就会退出子程序。

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

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

Get email address from email body in outlook vba

email

excel

outlook

vba