Outlook 2010中的未送达报告和VBA脚本 [英] Non-delivery reports and VBA script in Outlook 2010

问题描述

我有一个Outlook 2010 VBA脚本，该脚本应扫描收件箱中选定的未送达报告的正文，如果它们与正文中的某些正则表达式匹配，则将生成文本报告.最近，脚本停止工作，似乎我无法再访问所选对象的.body(debug.print在立即窗口中输出了很多问号).

I have a Outlook 2010 VBA script that should scan the body of selected non-delivery reports in my inbox and generates a text report if they match certain regular expressions in the body. Recently the script stopped working and it seems like I can no longer access the .body of the selected objects (debug.print outputs a lot of question marks to the immediate window).

该脚本对于收件箱中的常规(非NDR)电子邮件仍然可以正常工作.我还注意到突然之间的未送达报告似乎是HTML(或富文本格式)格式的.我最近要做的唯一事情是压缩我的电子邮件存档并关闭缓存模式.

The script still works fine for regular (not NDR) emails in my inbox. I also noticed that the non-delivery reports all of a sudden seem to be in an HTML (or rich text) format. The only thing I have done recently is compact my email archive and turn off cached mode.

感谢您的帮助！

以下是相关的脚本摘录:

Here is the relevant script excerpt:

Set Reg1 = New RegExp
With Reg1
    .Pattern = "some pattern"
    .Global = False
End With

Set Reg2 = New RegExp
With Reg3
    .Pattern = "yet another pattern"
    .Global = True
End With

With objFile
    .Write sMarker1
    .WriteBlankLines (1)
End With

For Each objItem In ActiveExplorer.Selection
    countEmail = countEmail + 1
    objItem.UnRead = False
    If Reg1.Test(objItem.Subject) Then
        If Reg2.Test(objItem.Body) Then
            Set M1 = Reg1.Execute(objItem.Body)
            For Each M In M1
                With objFile
                    .Write M.Value
                    .WriteBlankLines (1)
                End With
            Next
        End If
    End If
Next

推荐答案

我自己一直在处理一个非常相似的问题，可以对我的发现提供一些见识，希望对您的情况有所帮助.

I've been dealing with a very similar issue myself and can offer some insight into my discoveries, which I hope might be helpful in your situation.

如果NDR邮件的.Body显示为问号或中文字符，那是因为NDR实际上是由Outlook使用属性"即时"使用VBA无法使用的某些方法制作的.

If .Body for NDR messages are showing up as questions marks or Chinese characters then that's because the NDR is actually made by Outlook 'on the fly' using 'Properties' and by using certain methods inaccessible to VBA.

您可以使用一个名为Redemption的加载项来访问普通VBA不允许的所有信息，但是您需要在需要使用该代码的每台PC上安装并注册该信息(如果只有您需要使用它)，但对我来说这不是一个选择.

You can use an add-in called Redemption to gain access to all the information that normal VBA doesn't permit, but you need to install and register it on every PC you need the code to work with (which is OK if only YOU need to use it) but for me this wasn't an option.

要尝试实现的最简单的替代方法是先使用.SaveAs保存正文，然后再读回内容.我做了一些使它变得更容易的功能.

The easiest alternative to what you were trying to achieve is to save the body using .SaveAs first and then read the contents back. I've made some functions that might make it easier.

//usage example:
theBody = GetNDRBody(MailItem)

Function GetNDRBody(rItm As Object) As String
    Dim TheBody, TempFilePath As String
    If (LCase(rItm.MessageClass) = "report.ipm.note.ndr") Then
        TheBody = rItm.Body
        If Len(TheBody) > 0 Then
            If Chr(Asc(Left(TheBody, 1))) = "?" Then
                TempFilePath = AppDataDirectory & "\temp.txt"
                rItm.SaveAs TempFilePath, olTXT
                GetNDRBody = ReadFileContents(TempFilePath, True)
            End If
        End If
    End If
End Function

Function ReadFileContents(filePath As String, Optional DeleteWhenFinished As Boolean = False) As String
    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    If fso.FileExists(filePath) Then
        Dim FileStream As Object: Set FileStream = fso.OpenTextFile(filePath, 1)
        ReadFileContents = FileStream.ReadAll
        FileStream.Close
        If DeleteWhenFinished = True Then fso.DeleteFile (filePath)
    End If
End Function
Function AppDataDirectory() As String
    Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
    AppDataDirectory = fso.GetSpecialFolder(2)
    Set fso = Nothing
End Function

但是-我不确定您要扫描NDR的确切信息是什么，但是也可以使用属性"找到另一种方法.例如，以下是我用于从NDR提取失败的电子邮件列表的代码段:

HOWEVER - I'm not sure what exact information your scanning NDRs for, but it may also be possible to find an alternative way using a Property. For example, here is a snippet I used to fetch the failed email list from an NDR:

(仅当它们在NDR中显示为电子邮件时，紧接在标题向这些收件人或通讯组列表的传递失败:"下面.如果它显示为联系人姓名，则只有该姓名在该姓名中在我的情况下，当他们显示为联系人姓名时，我将使用我制作的GetNDRBody函数.

(it only works if they are displayed as an email in the NDR immediately below the title 'Delivery has failed to these recipients or distribution lists:'. If it instead shows as a contact name then only the name will be in that 'property'. In my case, when they showed as a contact name then I would use the GetNDRBody function I made)

Dim objItem As Object

If (objItem.MessageClass = "REPORT.IPM.Note.NDR") Then
    Dim propertyAccessor As propertyAccessor
    Set propertyAccessor = objItem.propertyAccessor

    FailEmail = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")

有时候会有一列用;"分隔的电子邮件列表，所以我将其拆分为一个数组并做了一个"for each"

Sometimes there is a list of emails separated by "; " so I split it into an array and did a 'for each'

我还设法以这种方式从邮件传递失败"电子邮件中获取了电子邮件列表，然后将它们分成，"(又是一小段)的数组

I also managed to get the email list from 'Mail Delivery Failed' emails this way, then spliting them into an array by ", " (this is just a snippet again)

If objItem.Subject = "Mail delivery failed: returning message to sender" Then
    Set propertyAccessor = objItem.propertyAccessor
    FailEmail = propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/string/{00020386-0000-0000-C000-000000000046}/x-failed-recipients/0x0000001F")
    FailEmail = Replace(FailEmail, ", ", vbNewLine)
...
FailEmails = Split(FailEmail, vbNewLine)
For Each FailedEmail in FailEmails

您还可以尝试下面的代码来查看所寻找的内容是否作为一个公共属性出现(也可以尝试安装OutlookSpy并查看此处是否未列出其他属性):

You can also try the below code to see if what you're looking for comes up as a common property (and you can also try installing OutlookSpy and see if there is a different property not listed here):

Set propertyAccessor = objItem.propertyAccessor
GetPropertyAccessorInfo propertyAccessor



Sub GetPropertyAccessorInfo(propertyAccessor As propertyAccessor)
   On Error Resume Next
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x001A001E"), , "PR_MESSAGE_CLASS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0037001E"), , "PR_SUBJECT"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x00390040"), , "PR_CLIENT_SUBMIT_TIME"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003B0102")), , "PR_SENT_REPRESENTING_SEARCH_KEY"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003D001E"), , "PR_SUBJECT_PREFIX PT_STRING8"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x003F0102")), , "PR_RECEIVED_BY_ENTRYID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0040001E"), , "PR_RECEIVED_BY_NAME"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x00410102")), , "PR_SENT_REPRESENTING_ENTRYID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0042001E"), , "PR_SENT_REPRESENTING_NAME"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x004F0102")), , "PR_REPLY_RECIPIENT_ENTRIES"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0050001E"), , "PR_REPLY_RECIPIENT_NAMES"

   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x00510102")), , "PR_RECEIVED_BY_SEARCH_KEY"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0064001E"), , "PR_SENT_REPRESENTING_ADDRTYPE"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0065001E"), , "PR_SENT_REPRESENTING_EMAIL_ADDRESS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0070001E"), , "PR_CONVERSATION_TOPIC"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x00710102")), , "PR_CONVERSATION_INDEX"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0075001E"), , "PR_RECEIVED_BY_ADDRTYPE"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0076001E"), , "PR_RECEIVED_BY_EMAIL_ADDRESS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E"), , "PR_TRANSPORT_MESSAGE_HEADERS"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C190102")), , "PR_SENDER_ENTRYID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1A001E"), , "PR_SENDER_NAME"

   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1D0102")), , "PR_SENDER_SEARCH_KEY"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1E001E"), , "PR_SENDER_ADDRTYPE"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0C1F001E"), , "PR_SENDER_EMAIL_ADDRESS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E02001E"), , "PR_DISPLAY_BCC"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E03001E"), , "PR_DISPLAY_CC"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E"), , "PR_DISPLAY_TO"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040"), , "PR_MESSAGE_DELIVERY_TIME"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E070003"), , "PR_MESSAGE_FLAGS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E080003"), , "PR_MESSAGE_SIZE"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E090102")), , "PR_PARENT_ENTRYID"

   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E12000D"), , "PR_MESSAGE_RECIPIENTS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E13000D"), , "PR_MESSAGE_ATTACHMENTS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B"), , "PR_HASATTACH"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1D001E"), , "PR_NORMALIZED_SUBJECT"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E1F000B"), , "PR_RTF_IN_SYNC"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E28001E"), , "PR_PRIMARY_SEND_ACCT"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E29001E"), , "PR_NEXT_SEND_ACCT"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF40003"), , "PR_ACCESS"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF70003"), , "PR_ACCESS_LEVEL"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF80102")), , "PR_MAPPING_SIGNATURE"

   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FF90102")), , "PR_RECORD_KEY"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFA0102")), , "PR_STORE_RECORD_KEY"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFB0102")), , "PR_STORE_ENTRYID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFE0003"), , "PR_OBJECT_TYPE"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0FFF0102")), , "PR_ENTRYID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1000001E"), , "PR_BODY"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10090102")), , "PR_RTF_COMPRESSED"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10130102")), , "PR_HTML"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1035001E"), , "PR_INTERNET_MESSAGE_ID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1045001E"), , "PR_LIST_UNSUBSCRIBE"

   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x1046001E"), , "N/A"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040"), , "PR_CREATION_TIME"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30080040"), , "PR_LAST_MODIFICATION_TIME"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x300B0102")), , "PR_SEARCH_KEY"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x340D0003"), , "PR_STORE_SUPPORT_MASK"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x340F0003"), , "N/A"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x34140102")), , "PR_MDB_PROVIDER"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3FDE0003"), , "PR_INTERNET_CPID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x80050003"), , "SideEffects"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x802A001E"), , "InetAcctID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x804F001E"), , "InetAcctName"
   MsgBox propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x80660102")), , "RemoteEID"
   MsgBox propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x80AD001E"), , "x-rcpt-to"
End Sub

这篇关于Outlook 2010中的未送达报告和VBA脚本的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！