Code to check Calendar VS Birthdays and Anniversaries

[Neal B. Scott]

I got tired of my calendar being a little out of synch with itself. I
want ALL birthday and ALL anniversaries in my contacts to be in my
calendar, no exceptions. Outlooks seems to handle them as optional on
occasion. Mostly as result of manual data imports. Anyway I wrote
some quicky code to see what bday's and anniversaries are missing from
the calendar and thought it may help someone else out there someday...



Option Explicit
Sub CheckBDayAnniv()
Debug.Print "Searching.."

Dim oOL As Outlook.Application
Set oOL = New Outlook.Application

Dim olns As Outlook.NameSpace
Set olns = oOL.GetNamespace("MAPI")

Dim PersonalFolders As Outlook.MAPIFolder
Set PersonalFolders = olns.Folders("Personal Folders")

Dim ContactFolder As Outlook.MAPIFolder
Set ContactFolder = PersonalFolders.Folders("CONTACTS")
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = PersonalFolders.Folders("Calendar")


Dim ContactItems As Outlook.Items 'notice this one is plural
Set ContactItems = ContactFolder.Items

Dim CurItem As Outlook.ContactItem 'and this one is not
Dim i As Integer
For Each CurItem In ContactItems

If CurItem.Birthday > #1/1/1900# And CurItem.Birthday <>
#1/1/4501# Then
Dim BDayFound As Boolean
BDayFound = False


Dim strBDay As String
strBDay = CurItem.Subject & "'s Birthday"

For i = 1 To CalendarFolder.Items.Count
If CalendarFolder.Items(i) = strBDay Then
BDayFound = True
Exit For
End If
Next
If BDayFound = False Then
Debug.Print strBDay
End If
End If
Next

For Each CurItem In ContactItems

If CurItem.Anniversary > #1/1/1900# And CurItem.Anniversary <>
#1/1/4501# Then
Dim AnnFound As Boolean
AnnFound = False

Dim strAnnDay As String
strAnnDay = CurItem.Subject & "'s Anniversary"

For i = 1 To CalendarFolder.Items.Count
If CalendarFolder.Items(i) = strAnnDay Then
AnnFound = True
Exit For
End If
Next
If AnnFound = False Then
Debug.Print strAnnDay
End If
End If
Next

Debug.Print "done."
End Sub