How to assign a retention tag to a mail item in Outlook VBA?

Question

I'm trying to write a macro which will be going through a folder in Outlook assigning a retention tag (docs) to some items based on some complicated criteria.

I don't know how to do this in VBA. So far I've learned that mail items have some retention related properties (PidTagPolicyTag (docs), etc.), but I still don't know how to deal with them properly.

What would be some examples of using with these?

Answer 1

Take a look at an existing message with these properties set using OutlookSpy (I am its author - click IMessage) or MFCMAPI. PR_POLICY_TAG / PR_RETENTION_PERIOD / PR_RETENTION_DATE properties can be set using MailItem.PropertyAccessor.SetProperty.

Answer 2

Here is an example of applying a retention tag to messages using 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