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.)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
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.