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

【问题标题】：Outlook Undeliverable Bounce Report-Item Search Issues, VBAOutlook 无法投递的退回报告-项目搜索问题，VBA
【发布时间】：2016-02-05 16:22:33
【问题描述】：

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

我有一些适用于常规电子邮件的 VBA 代码，但由于无法投递的不是 Outlook“邮件项目”，它们是 Outlook“报告项目”，我在搜索邮件时遇到问题。搜索功能又空了回来，经过大量研究，似乎“报告项目”实际上没有可以搜索的“主体”。

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

(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

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

【问题讨论】：

（我从您的标题中删除了“已解决”。由于您接受了答案，这对于其他有类似问题的人来说是正确的指示。）

标签： vba email outlook report

【解决方案1】：

我最终采用的解决方案是将邮件正文转换回 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

【讨论】：

【解决方案2】：

嗯，总是有this 解决方案。

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

希望这会有所帮助！

【讨论】：

这个解决方案很有趣，但在论坛的底部，我曾经有另一个想法来解决这个问题。谢谢！