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:
Outlook RuleTo 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) <> retPolicy Then
        IsEqual = False
        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
    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.

Leave a Reply

Your email address will not be published. Required fields are marked *