Trigger Actions With Categories

Move all Emails to a Subfolder

The first example moves an email to a certain subfolder of the inbox as soon as you assign a certain category. If more categories are assigned, they'll be ignored. Just customize the two variables in the 'Mail_PropertyChange' procedure (the category to look for, and the name of the subfolder).

As Outlook does not allow moving a message from within the PropertyChange procedure, we start a timer to move the message after the PropertyChange has been completed.

Get the code for the API Timer here.

  How to add macros to Outlook

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim SubfolderName As String
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String

  'Enter here the category name to look for
  FindCategory = " (Actionlist)"
  'Enter here the name of the subfolder
  SubfolderName = "test"

  Set Ns = Application.GetNamespace("MAPI")
  Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
  Set Subfolder = Inbox.Folders(SubfolderName)
  If Subfolder.EntryID = Mail.Parent.EntryID Then
    Exit Sub
  End If

  If Name = "Categories" Then
    Cats = LCase$(Mail.Categories)
    FindCategory = LCase$(FindCategory)
    If Len(Cats) = 0 Then Exit Sub
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        Set MoveToThisFolder = Subfolder
        EnableTimer 500, Me
        Exit For
      End If
    Next
  End If
End Sub

Friend Sub TimerEvent()
  DisableTimer
  If Mail Is Nothing Then Exit Sub
  If MoveToThisFolder Is Nothing Then Exit Sub
  Mail.Move MoveToThisFolder
  Set Mail = Nothing
  Set MoveToThisFolder = Nothing
End Sub

Move to a Folder with the Name of the Category

The second example moves the email to a subfolder of the inbox that matches the name of the category. Again, the moving itself will be triggered by the timer.

Get the code for the API Timer here.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim SubfolderName As String

  If Name = "Categories" Then
    Set Ns = Application.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
    SubfolderName = Mail.Categories
    If Len(SubfolderName) = 0 Then Exit Sub
    Set Subfolder = Inbox.Folders(SubfolderName)
    If Subfolder.EntryID <> Mail.Parent.EntryID Then
      Set MoveToThisFolder = Subfolder
      EnableTimer 500, Me
    End If
  End If
End Sub

Friend Sub TimerEvent()
  DisableTimer
  If Mail Is Nothing Then Exit Sub
  If MoveToThisFolder Is Nothing Then Exit Sub
  Mail.Move MoveToThisFolder
  Set Mail = Nothing
  Set MoveToThisFolder = Nothing
End Sub

Run all Your Rules

This sample runs all the rules you have set up as soon as you assign the category '(RunRules)' to an email.

This one requires Outlook 2007 or higher.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim CurrentFolder As Outlook.Folder
  Dim CurrentStore As Outlook.Store
  Dim Rules As Outlook.Rules
  Dim Rule As Outlook.Rule
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String
  Dim RunRules As Boolean

  'Enter here the name of your category
  FindCategory = "(RunRules)"

  If Name = "Categories" Then
    Cats = LCase$(Mail.Categories)
    FindCategory = LCase$(FindCategory)
    If Len(Cats) = 0 Then Exit Sub
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        Set Mail = Nothing
        RunRules = True
        Exit For
      End If
    Next
  End If

  If RunRules Then
    Set CurrentFolder = Application.ActiveExplorer.CurrentFolder
    Set CurrentStore = CurrentFolder.Store
    Set Rules = CurrentStore.GetRules
    For Each Rule In Rules
      If Rule.Enabled Then
        Rule.Execute
      End If
    Next
  End If
End Sub

Flag an Appointment Private

This code flags an appointment as private when you assign a certain category. Change the category name in the PropertyChange procedure to suit your needs.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Appointment As Outlook.AppointmentItem

Friend Sub Application_Startup()
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Appointment = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.AppointmentItem Then
      Set Appointment = obj
    End If
  End If
End Sub

Private Sub Appointment_PropertyChange(ByVal Name As String)
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String
  Dim RunRules As Boolean

  'Enter here the category name that should trigger the action
  FindCategory = "(Actionlist)"

  If Name = "Categories" Then
    Cats = LCase$(Appointment.Categories)
    If Len(Cats) = 0 Then Exit Sub
    FindCategory = LCase$(FindCategory)
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        RunRules = True
        Exit For
      End If
    Next
  End If

  If RunRules Then
    Appointment.Sensitivity = olPrivate
    Appointment.Save
  End If
End Sub