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

Question

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

我不知道如何在 VBA 中做到这一点。到目前为止，我已经了解到邮件项目具有一些与保留相关的属性（PidTagPolicyTag（文档）等），但我仍然不知道如何正确处理它们。

与这些一起使用的一些例子是什么？

Answer 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

Answer 2

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