Outlook Scripting

In the battle of me vs the overwhelming number of contact birthdays in our calendar, I have won! I have successfully scripted Outlook to look up the categories of the contacts and apply them to the contacts' birthdays. Now, I can simply set a filter to not show the contacts that aren't close friends or family.

Before:

After:

The script (press Alt+F11 in Outlook to open the VB editor):

Sub SetBirthdayCategories()
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim oAppt As Outlook.AppointmentItem

' Obtain calendar events list
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items

' run DoBirthday on recurring appointments
For Each oAppt In oCalendar.Items
If oAppt.IsRecurring Then

Call DoBirthday(oAppt)

' tweak reminder logic
If InStr(oAppt.subject, "'s Birthday") Then
  If InStr(oAppt.Categories, "4 Relatives") <> 0 _
  Or InStr(oAppt.Categories, "5 Friends") <> 0 _
  Or InStr(oAppt.Categories, "6 Ministry") <> 0 _
  Or InStr(oAppt.Categories, "7 Professional") <> 0 _
  Or InStr(oAppt.Categories, "8 Medical") <> 0 _
  Or InStr(oAppt.Categories, "9 Acquaintences") <> 0 Then
      ' these people have no reminder
      oAppt.ReminderSet = False
  Else
      ' family and close friends have 1 week reminder
      oAppt.ReminderSet = True
      oAppt.ReminderOverrideDefault = True
      oAppt.ReminderMinutesBeforeStart = 7 * 24 * 60 ' 1 week
  End If

  ' Don't forget to save changes!
  oAppt.Save

End If

End If
Next
End Sub


Sub DoBirthday(ByRef oAppt As Outlook.AppointmentItem)
Dim sArray As Variant
Dim oContact As ContactItem
Dim filteredItems As Outlook.Items
Dim oCategories As String
Dim bCategoriesMatch As Boolean
Dim sFilter As String
Dim subject As String

subject = oAppt.subject

If InStr(subject, "Anniversary") <> 0 Then
Exit Sub
End If

' remove "'s Birthday" to get just contact's name
subject = Replace(subject, "'s Birthday", "")
Debug.Print subject

sArray = Split(subject)

' obtain last name; take off "Sr." (or anything with a "." in it)
Dim sLastName
For i = LBound(sArray) To UBound(sArray)
If InStr(sArray(i), ".") = 0 Then
sLastName = sArray(i)
Else
sArray(i) = ""
End If
Next

' Restrict contacts by LastName
sFilter = "[LastName] = " & sLastName
Set oContacts = Application.Session.GetDefaultFolder(olFolderContacts)
Set filteredItems = oContacts.Items.Restrict(sFilter)

' Early out if nothing was found
If filteredItems.Count = 0 Then
Exit Sub
End If

bCategoriesMatch = True
oCategories = ""

' search for all appointment subject's elements matching being inside contact's FullName
For Each oContact In filteredItems

If (bCategoriesMatch And oCategories = "") Then
oCategories = oContact.Categories
End If

If oCategories <> oContact.Categories Then
oCategories = ""
bCategoriesMatch = False
End If

For i = LBound(sArray) To UBound(sArray)
If InStr(oContact.FullName, sArray(i)) = 0 Then
  GoTo last
End If
Next

'Debug.Print "   Matched contact '" & oContact.FullName & "': " & oContact.Categories
Call SetCategories(oAppt, oContact.Categories)
Exit Sub
last:
Next

' Didn't find an exact match.  If all the contacts have the same categories, then that's the one for us
If bCategoriesMatch Then
'Debug.Print "   All contacts had category: " & oCategories
Call SetCategories(oAppt, oCategories)
End If

End Sub


Sub SetCategories(ByRef oAppt As Outlook.AppointmentItem, oCategories As String)
If oCategories = "" Then
oAppt.Categories = "Birthday"
Exit Sub
End If

' append "'s Birthday to the appointment's subject
oAppt.subject = Replace(oAppt.subject, "'s Birthday", "")
oAppt.subject = oAppt.subject & "'s Birthday"

oAppt.Categories = oCategories & ", Birthday"
oAppt.Save
End Sub

(Stupid VB editor won't copy with the color formatting)

Now I just change my filter (View->Current View->Customize Current View...->Filter) and set the "SQL" field to be:

(NOT("urn:schemas-microsoft-com:office:office#Keywords" = '4 Relatives' OR "urn:schemas-microsoft-com:office:office#Keywords" = '5 Friends' OR "urn:schemas-microsoft-com:office:office#Keywords" = '6 Ministry' OR "urn:schemas-microsoft-com:office:office#Keywords" = '7 Professional' OR "urn:schemas-microsoft-com:office:office#Keywords" = '8 Medical' OR "urn:schemas-microsoft-com:office:office#Keywords" = '9 Aquaintences' OR "urn:schemas-microsoft-com:office:office#Keywords" = '91 Restaraunts'))

And that's it!