Saturday, 30 April 2016

Easily update your 'newsletters' rule with e-mail sender addresses

If, like me, you get inundated with 'informative' e-mails which you would like to get around to reading some time so don't want to unsubscribe, but you don't want them cluttering up your inbox then read on.

The following shows how you can easily add sender's e-mail addresses to an existing Outlook e-mail rule which, for example, moves these e-mails to a 'read later' folder.

The following VBA code finds the 'current' e-mail or selection of e-mails and adds the e-mail sender(s) to the named rule.

How-to create the rule and insert the code

  1. Create a new rule which includes the condition 'with specific words in the sender's address' and, for example, move them to a '@later' folder:

  2. Give this rule a name. e.g. 'Newsletters'. 
  3. Open the Outlook VBA IDE using Alt-F11.
  4. Insert a new Module (Insert|Module)
  5. Paste the code at the end of this article
  6. Update the cRuleName$ to be the name of the rule you created earlier in step 2.

There are now 2 methods you can call:

  • AddCurrentSenderToReadLater()
    Call this if you want the current e-mail item to be added to your rule
  • AddSelectedSendersToReadLater()
    Call this if you want to add the selected mail items in the mail explorer to your rule

I have added a button to my main Outlook Quick Access Toolbar to call AddSelectedSendersToReadLater()

and one to my e-mail item Quick Access Toolbar to call AddCurrentSenderToReadLater().

The VBA code module

' Add the currently selected sender to an existing rule.
' The rule (see cRuleName) must be conditioned on sender's e-mail addresses
' i.e. include a condition that is
'   With 'specific words' in the sender's e-mail address
' These functions take the address of the sender of the current e-mail(s) and adds it to the list
'   * To add senders in the current e-mail active explorer (e.g. inbox) call AddSelectedSendersToReadLater
'   * To add the sender of the currently opened e-mail call AddCurrentSenderToReadLater
Option Explicit

' The name of the rule to update
Private Const cRuleName$ = "Newsletters"

Private Enum enumErrorValues
  errUnableToFindRule = vbObjectError + 1000
End Enum

' Call this to add the current e-mail's sender
Public Sub AddCurrentSenderToReadLater()
  On Error GoTo oops
  If Application.ActiveInspector Is Nothing Then ErrRaise enumErrorValues.errNoSelection
  Dim mail As Outlook.MailItem
  Set mail = Application.ActiveInspector.currentItem
  If mail Is Nothing Then ErrRaise enumErrorValues.errNoMailSelection
  Dim emails(1 To 1) As Outlook.MailItem
  Set emails(1) = mail
  AddSendersToReadLater cRuleName$, emails
  Exit Sub
  MsgBox err.Description, vbCritical, "Error"
End Sub

' Add all selected mail items' senders
Public Sub AddSelectedSendersToReadLater()
  On Error GoTo oops
  Dim emails() As Outlook.MailItem
  ' The side-effect of the following is to set the dimensions of the array to (0 to -1)
  IsArray emails
  Dim ObjItem As Object 'Outlook.MailItem
  For Each ObjItem In Application.ActiveExplorer.Selection
    If ObjItem.Class = olMail Then
      ReDim Preserve emails(0 To UBound(emails) + 1) As Outlook.MailItem
      Set emails(UBound(emails)) = ObjItem
    End If

  AddSendersToReadLater cRuleName$, emails
  Exit Sub
  MsgBox err.Description, vbCritical, "Error"
End Sub

Private Function GetDefaultFolder() As Outlook.Folder
  Dim myNamespace As Outlook.NameSpace

  Set myNamespace = Application.GetNamespace("MAPI")
  Set GetDefaultFolder = myNamespace.GetDefaultFolder(olFolderInbox)
End Function

Private Sub AddSendersToReadLater(ruleName, emails() As Outlook.MailItem)
  Dim Session As Outlook.NameSpace
  Set Session = Application.Session
  Dim rules As Outlook.rules
  Set rules = Session.DefaultStore.GetRules()
  Dim rule As Outlook.rule
  For Each rule In rules
    If rule.Name = ruleName Then
      Debug.Assert rule.Conditions.SenderAddress.ConditionType = olConditionSenderAddress
      Dim addressesAdded$, addressesIgnored$
      Dim obj 'As Outlook.MailItem
      For Each obj In emails
        If Not obj Is Nothing Then
          Dim email As Outlook.MailItem
          Set email = obj
          Dim address$
          If AddMailItemSenderToReadLater(rule, email, address) Then
            addressesAdded$ = addressesAdded$ & vbCr & vbTab & address
            addressesIgnored$ = addressesIgnored$ & vbCr & vbTab & address
          End If
        End If
      If addressesAdded$ <> "" Then rules.Save
      ' execute the rule whether we updated it or not
      rule.Execute True, GetDefaultFolder
      Dim msg$
      If addressesAdded <> "" Then msg = "Added these e-mail addresses:" & vbCr & addressesAdded
      If addressesIgnored <> "" Then
        If msg <> "" Then msg = msg & vbCr
        msg = msg & "These e-mail addresses are already being managed:" & vbCr & addressesIgnored
      End If
      If msg = "" Then
        MsgBox "No senders found to update", vbOKOnly, "Rule '" & cRuleName & "'"
        MsgBox msg, vbOKOnly, "Rule '" & cRuleName & "'"
      End If
      Exit Sub
    End If
  ErrRaise errUnableToFindRule
End Sub

Private Function AddMailItemSenderToReadLater(rule As Outlook.rule, mail As Outlook.MailItem, ByRef address$) As Boolean
  ' NOTE: The address looks 'ugly' if it's an internal exchange address but it does seem to work
  address = mail.SenderEmailAddress
  If address <> "" Then
    AddMailItemSenderToReadLater = UpdateRule(rule, address)
    MsgBox "Unable to find address for this e-mail!" & vbCr _
      & vbCr _
      & "  Subject: " & mail.Subject & vbCr _
      & "  To: " & mail.To & vbCr
  End If
End Function

Private Function UpdateRule(rule As Outlook.rule, senderToIgnore$) As Boolean
  Dim addresses$()
  addresses = rule.Conditions.SenderAddress.address
  UpdateRule = True
  Dim address
  For Each address In addresses
    If StrComp(address, senderToIgnore, vbTextCompare) = 0 Then
      'Debug.Print address & ": Sender already in list"
      UpdateRule = False
      Exit For
    End If
  If UpdateRule Then
    ReDim Preserve addresses(UBound(addresses) + 1)
    addresses(UBound(addresses)) = senderToIgnore
    rule.Conditions.SenderAddress.address = addresses
  End If
End Function

Private Sub ErrRaise(errorNumber As enumErrorValues)
  Select Case errorNumber
    Case errUnableToFindRule
      err.Raise errorNumber, Description:="Unable to find the Outlook rule '" & cRuleName & "'"
    Case errCodingError
      err.Raise errorNumber, Description:="Coding error!"
    Case errNoSelection
    Case errNoMailSelection
      err.Raise errorNumber, Description:="Please select an e-mail and try again"
    Case Else
      err.Raise errorNumber, Description:="Unknown Error!"
  End Select
End Sub

No comments: