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不会将其视为0。

由于MailItem已被声明为olMail，因此在迭代Outlook.MailItem集合时，一旦发现一个此类事件，它就会退出该子集。

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

即可

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

2 个答案: