A pedant that hangs out in the dark corner-cases of the web.

Thursday, August 07, 2014

Macro to set Outlook email expiration with subject hashtag

When you return from vacation, you probably have a ton of irrelevant spam for events that happened while you were gone but are no longer useful, like:
  • people leaving early/coming in late
  • lunch/available food
  • server reboots
  • weather/traffic warnings
One way to reduce this noise is to set an expiration on emails of this nature. Sadly, Microsoft Outlook has deeply hidden the UI to do this, so most people don't remember, can't figure it out, or can't be bothered.
Here is a macro that lets you set the expiration date for an email by just adding certain hashtags to your subject. Adding #today sets the expiration for the end of the day, otherwise you can use ISO 8601 durations as hashtags, like #PT2H for two hours, or #P1W for a week.

Public WithEvents Item As Outlook.MailItem

Private Function DateUnit(ByVal isoUnit, ByVal isYmwdPart) As String
    Select Case isoUnit
        Case "Y": DateUnit = "yyyy"
        Case "W": DateUnit = "ww"
        Case "M":
            If isYmwdPart Then
                DateUnit = "m"
            Else
                DateUnit = "n"
            End If
        Case Else: DateUnit = isoUnit
    End Select
End Function

Private Function AddIsoDuration(ByVal start As Date, ByVal isoDuration As String) As Date
    Dim value, durationMatch, nextPart
    value = start
    Set durationMatch = New RegExp
    durationMatch.Pattern = "^(P((\d+[YMWD])*)(T((\d+[HMS])+))?)$"
    Set nextPart = New RegExp
    nextPart.Pattern = "^(\d+)([YMWDHMS])"
    Set matched = durationMatch.Execute(isoDuration)(0)
    ymwd = matched.SubMatches(1)
    hms = matched.SubMatches(4)
    Do Until Len(ymwd) = 0
        Set part = nextPart.Execute(ymwd)(0)
        value = DateAdd(DateUnit(part.SubMatches(1), True), CInt(part.SubMatches(0)), value)
        ymwd = Mid(ymwd, Len(part) + 1)
    Loop
    Do Until Len(hms) = 0
        Set part = nextPart.Execute(hms)(0)
        value = DateAdd(DateUnit(part.SubMatches(1), False), CInt(part.SubMatches(0)), value)
        hms = Mid(hms, Len(part) + 1)
    Loop
    AddIsoDuration = value
End Function

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim durationMatch
    Set durationMatch = New RegExp
    durationMatch.Pattern = "#(P(\d+[YMWD])*(T(\d+[HMS])+)?)\b"
    ExpiryTime = Item.ExpiryTime
    If InStr(1, Item.Subject, "#today", vbTextCompare) > 0 Then
        If ExpiryTime = #1/1/4501# Then
            Item.ExpiryTime = DateAdd("d", 1, Date)
        End If
    ElseIf durationMatch.Test(Item.Subject) Then
        If ExpiryTime = #1/1/4501# Then
            Item.ExpiryTime = AddIsoDuration(Now, durationMatch.Execute(Item.Subject)(0).SubMatches(0))
        End If
    End If
    Item.Save
End Sub