Question

我在文件夹中有一些无法投递的电子邮件。我正在尝试浏览文件夹中的每封电子邮件，并通过搜索邮件拉出目标收件人的电子邮件地址。

我有一些VBA代码适用于普通电子邮件，但由于无法投递的Outlook＆＃34;邮件项目＆＃34;，它们是Outlook＆＃34;报告项目＆＃34;，我在搜索邮件时遇到问题。搜索功能是空的，经过大量的研究，似乎可能＆＃34;报告项目＆＃34;实际上没有＆＃34;身体＆＃34;可以搜索。

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

(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

我最终解决的问题是将邮件正文转换回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

Answer 2

嗯，总有here解决方案。

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

希望这有帮助！

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

2 个答案: