Outlook 无法送达退回报告 - 项目搜索问题，VBA [英] Outlook Undeliverable Bounce Report-Item Search Issues, VBA

问题描述

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

I have some undeliverable emails in a folder. I am trying to go through each email in the folder and pull out the intended recipients email address by searching the message.

我有一些适用于常规电子邮件的 VBA 代码，但由于无法送达的不是 Outlook邮件项目"，它们是 Outlook报告项目"，我在搜索邮件时遇到问题.搜索功能回来了，经过大量研究，似乎报告项目"实际上没有可以搜索的正文".

I have some VBA code that works on regular emails, but since undeliverable's aren't Outlook "Mail Items", they are Outlook "Report Items", I am having issues searching the message. The search function is coming back empty and after a lot of research, it seems that maybe "Report Items" do not actually have a "body" that can be searched.

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

The email in all the error reports are in the following format in the report.

([e-mail])

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

Here is the code I am using, which works on normal Mail Items.

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

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

Does anyone know how I can access the message part of the report for searching purposes?

推荐答案

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

The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.

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

Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.

希望这对未来的人有所帮助！

Hopefully this helps someone in the future!

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的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！