Outlook macro to assign retention policy when item is deleted

I described in another post how I need to assign a retention policy tag to items in my Deleted Items folder because there isn’t a retention policy tag set on the folder. I also set a different tag to items in my Sent Items folder. While I run the script in that post every week or so, because of the large volume of mail I receive and subsequently delete, the script will sometimes need to process over a thousand items. Updating that many items with EWS is not the fastest process, so I looked into how Outlook can do it for me at the time a message is put in its respective folder.

Applying a personal tag to sent items is easy because a rule can be created to assign the tag when items are sent:
To have a tag assigned when items are moved to the Deleted Items folder, I needed to create a macro that runs when the items are moved. This can be done with an event that is registered when Outlook starts. Paste the following code into ThisOutlookSession and restart Outlook. (You will want to change the two constants to be the GUID and number of days for your tag.)

Public WithEvents deletedItems As Outlook.Items

Public Sub Application_Startup()
    Set deletedItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Items
End Sub

Public Sub deletedItems_ItemAdd(ByVal Item As Object)
    Const retPolicy As String = "03DACE3336054C428ECAE839E0BC5945" '30 Day tag GUID
    Const retPeriod As Long = 30 'Number of days the tag is set to expire items
    Set pa = Item.PropertyAccessor
    p = Empty
    On Error Resume Next
    p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get policy tag
    On Error GoTo 0
    If IsEmpty(p) Then
        IsEqual = False
    ElseIf pa.BinaryToString(p) &lt;&gt; retPolicy 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 delivery date
        On Error GoTo 0
        If IsEmpty(msgDate) Then
            msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get creation date
        End If
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy) 'Set poliy tag
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set retention period days
    pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set date of expiration
    Item.Save
    End If
End Sub

Public WithEvents deletedItems As Outlook.Items

Public Sub Application_Startup()

Set deletedItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Items

End Sub

Public Sub deletedItems_ItemAdd(ByVal Item As Object)

Const retPolicy As String = "03DACE3336054C428ECAE839E0BC5945" '30 Day tag GUID

Const retPeriod As Long = 30 'Number of days the tag is set to expire items

Set pa = Item.PropertyAccessor

p = Empty

On Error Resume Next

p = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30190102") 'Get policy tag

On Error GoTo 0

If IsEmpty(p) Then

IsEqual = False

ElseIf pa.BinaryToString(p) <> retPolicy 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 delivery date

On Error GoTo 0

If IsEmpty(msgDate) Then

msgDate = pa.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30070040") 'Get creation date

End If

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30190102", pa.StringToBinary(retPolicy) 'Set poliy tag

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301A0003", retPeriod 'Set retention period days

pa.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x301C0040", msgDate + retPeriod 'Set date of expiration

Item.Save

End If

End Sub

Both the rule and the macro only run when Outlook is the client doing the operation, so any messages sent or deleted from a mobile device (or OWA) won’t have the respective tag assigned. This means I still have a need to run the script, but it will need update far fewer items and, therefore, complete in much less time.

2 thoughts on “Outlook macro to assign retention policy when item is deleted”

Scott on December 12, 2017 at 10:41 AM said:

An easy way to get the GUIDs for tags is to use EWSEditor, connect to the mailbox, then select Tools->User Settings…->User Retention Tags…, then Display User’s Retention Tags. The GUIDs will be in the RetentionId column. The benefit of using EWSEditor is that it also shows the display name of the tag so you can easily determine which GUID to use.
Leon on December 12, 2017 at 12:25 PM said:

Thank you! Your is the first sample code I found that set Retention Policy via VBA. It would be nice is you can explain where to obtain the other GUIDD apart from the 30 Day tag GUID, and the other propotag. Nonetheless, Thanks!