Populating Birthday From Contacts

This is completely off topic and has everything to do with Outlook and my calendar.  While traveling something happened to my contact and calendar synchronization and I ended up with 4 or 5 birthdays for all of my contacts.  Some were on a single day and others started and ended 2-hours early – most likely the consequence of traveling to the west coast.

Anyway I deleted all of the birthdays on my calendar last weekend and wanted to re-populate them.  Unfortunately there isn’t anything automated that will do this.  So I found a Microsoft article on Programatically Change the Display Format for All Contacts and modified it to fit my needs.

The code below is what I am using to do this:

Private Sub UpdateBirthday()
    Dim items As items, item As ContactItem, folder As folder

    Dim contactItems As Outlook.items
    Dim itemContact As Outlook.ContactItem

    Set folder = Session.GetDefaultFolder(olFolderContacts)
    Set items = folder.items
    Count = items.Count

    If Count = 0 Then
        MsgBox "Nothing to do!"
        Exit Sub
    End If

    'Filter on the message class to obtain only contact items in the folder
    Set contactItems = items.Restrict("[MessageClass]='IPM.Contact'")

    For Each itemContact In contactItems
        If Not itemContact.Birthday = #1/1/4501# Then
            itemContact.Birthday = itemContact.Birthday
       End If

    MsgBox "Your calendar has been updated."
End Sub

I am primarily posting this because all of the searches I did all pointed to software that could be purchased to do this and that seemed a bit overboard to me.  Just add this to a macro in your Outlook session and it works like a champ.