如何为 Outlook VBA 中的邮件项目分配保留标记？答案

【问题标题】：How to assign a retention tag to a mail item in Outlook VBA?如何为 Outlook VBA 中的邮件项目分配保留标记？
【发布时间】：2014-11-19 08:15:26
【问题描述】：

我正在尝试编写一个宏，该宏将通过 Outlook 中的一个文件夹，根据一些复杂的标准为某些项目分配保留标记 (docs)。

我不知道如何在 VBA 中执行此操作。到目前为止，我了解到邮件项具有一些与保留相关的属性（PidTagPolicyTag (docs) 等），但我仍然不知道如何正确处理它们。

有哪些使用这些的例子？

【问题讨论】：

标签： vba outlook retention

【解决方案1】：

以下是使用 Outlook VBA 将保留标记应用于邮件的示例：

Option Explicit

Private Sub Application_Startup()
    Const retPolicy7Y As String = "C16486BDBB1B384C9BDE0C2479537191" 'Document Retention  -  07 Years (7 years)
    Const retPeriod As Long = 2555 '7*365 days
    Dim mapi As NameSpace, sentItems As Items, cutOffDate As Date
    Dim i As Long, pa As PropertyAccessor, p As Variant, isEqual As Boolean, msgDate As Variant

    Set mapi = GetNamespace("MAPI")
    Set sentItems = mapi.GetDefaultFolder(olFolderSentMail).Items
    sentItems.Sort "SentOn", True
    cutOffDate = Now - 14

    For i = 1 To sentItems.Count
        If sentItems(i).SentOn <= cutOffDate Then
            Exit For
        End If

        Set pa = sentItems(i).PropertyAccessor
        p = Empty
        On Error Resume Next
        p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get PR_POLICY_TAG
        On Error GoTo 0

        If IsEmpty(p) Then
            isEqual = False
        ElseIf pa.BinaryToString(p) <> retPolicy7Y Then
            isEqual = False
        Else
            isEqual = True
        End If

        If Not isEqual Then
            msgDate = Empty
            On Error Resume Next
            msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040") 'Get PR_MESSAGE_DELIVERY_TIME
            On Error GoTo 0
            If IsEmpty(msgDate) Then
                msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get PR_CREATION_TIME
            End If

            pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy7Y) 'Set PR_POLICY_TAG
            pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set PR_RETENTION_PERIOD
            pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set PR_RETENTION_DATE
            sentItems(i).Save
        End If
    Next i
End Sub

【讨论】：

【解决方案2】：

查看使用OutlookSpy（单击IMessage）或MFCMAPI 设置这些属性的现有消息。可以使用 MailItem.PropertyAccessor.SetProperty 设置属性。

【讨论】：