Set the Expiry Date for an Email

Daily we get a lot of e-mails that we want to keep just for a specific time and then delete them. So that you don't have to read the e-mail time and again for determining whether or not it can be deleted now, you can set an expiry time for the message. Outlook displays the message crossed out when it's due. Then you can see easily at a glance what messages can be deleted (even that could be automated).

This sample demonstrates how you can set the expiry time with only two clicks either for an opened or for all of the selected items in a folder. The dialog asks you for a number of weeks with a default value of eight. If you click OK, the message will expire in eight weeks from today. If you enter a zero instead then the expiry time gets deleted. Entering a negative figure will display the message immediately as expired.

  How to add macros to Outlook

Public Sub SetExpiryTime()
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim Interval As Long
  Dim ExpiryTime As Date
  Dim Text$

  If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    Set obj = Application.ActiveInspector.CurrentItem

  Else
    Set Sel = Application.ActiveExplorer.Selection
    If Sel.Count = 0 Then
      Exit Sub
    Else
      Set obj = Sel(1)
    End If
  End If

  Select Case True
  Case (TypeOf obj Is Outlook.MailItem), _
    (TypeOf obj Is Outlook.MeetingItem), _
    (TypeOf obj Is Outlook.PostItem)

    ExpiryTime = obj.ExpiryTime
  End Select

  If ExpiryTime = #1/1/4501# Then
    Text = "-"
  Else
    Text = ExpiryTime
  End If

  Text = "Current expiry time: " & Text & vbCrLf & vbCrLf
  Text = Text & "In how many weeks should the selection expire?"
  Text = InputBox(Text, , "8")

  If Len(Text) Then
    Interval = Val(Text)

    If Interval Then
      ExpiryTime = DateAdd("ww", Interval, Date)
    Else
      ExpiryTime = #1/1/4501#
    End If

    If Not Sel Is Nothing Then
      For Each obj In Sel

        Select Case True
        Case (TypeOf obj Is Outlook.MailItem), _
          (TypeOf obj Is Outlook.MeetingItem), _
          (TypeOf obj Is Outlook.PostItem)

          obj.ExpiryTime = ExpiryTime
          obj.Save
        End Select
      Next

    Else
      Select Case True
      Case (TypeOf obj Is Outlook.MailItem), _
        (TypeOf obj Is Outlook.MeetingItem), _
        (TypeOf obj Is Outlook.PostItem)

        obj.ExpiryTime = ExpiryTime
        obj.Save
      End Select
    End If
  End If
End Sub