Outlook 无法投递的退回报告 - 项目搜索问题，VBA

Question

我的文件夹中有一些无法送达的电子邮件。我正在尝试浏览文件夹中的每封电子邮件，并通过搜索邮件来提取预期收件人的电子邮件地址。

我有一些适用于常规电子邮件的 VBA 代码，但由于无法送达的不是 Outlook "Mail Items"，它们是 Outlook "Report Items"，我在搜索邮件时遇到问题。搜索功能空着回来，经过大量研究，似乎 "Report Items" 实际上并没有可以搜索的 "body"。

所有错误报告中的电子邮件在报告中均采用以下格式。

(xxxxxx@xxxxxx.com)

这是我正在使用的代码，适用于普通邮件项目。

Sub Undeliver()

On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")

'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder

'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"

'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(I)

    'selects the body of the current email being searched
    msgtext = myitem.Body

    'searches the body for the first open parentheses and first close
    'parentheses and copies the value in between into an array
    delimtedMessage = Replace(msgtext, "(", "###")
    delimtedMessage = Replace(delimtedMessage, ")", "###")

    'splits the array up into two pieces
    messageArray = Split(delimitedMessage, "###")

    'this inputs the values of the array into my excel spreadsheet
    xlobj.Range("a" & I + 1).Value = messageArray(1)
    xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I

End Sub

有谁知道我如何访问报告的消息部分以进行搜索？

Answer 1

好吧，总有 this 解决方案。

要点是ReportItem.Body returns一个不可读的字符串，所以这个解决方案将ReportItem保存为文本文件，然后解析文本文件。它不是很优雅，但它应该工作。

希望对您有所帮助！

Answer 2

我最终采用的解决方案涉及将消息正文转换回 Unicode，然后搜索我需要的内容。这最终实现起来非常简单。

这是我完成的工作代码，以供将来参考。我最终添加了一个进度条来监控它在代码中的位置。不幸的是，它运行得相当慢，但它完成了工作。

希望这对以后的人有所帮助！

On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")

Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True

For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
    Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
    msgtext = StrConv(myitem.Body, vbUnicode)

    delimtedMessage = Replace(msgtext, "mailto:", "###")
    delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
    messageArray = Split(delimtedMessage, "###")

    xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
    xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I

xlobj.Application.displayStatusBar = False

Outlook 无法投递的退回报告 - 项目搜索问题，VBA

Outlook Undeliverable Bounce Report-Item Search Issues, VBA

email

outlook

vba

report