Open your Outlook, goto Tools -> Macro -> Visual Basic Editor
Do a right-button on ThisOutlookSession and insert a module.
Paste the code below, and run.
Sub FindBirthdays()
Dim Person As Variant
Dim Bday As Variant
Dim NewBday As Outlook.AppointmentItem
Dim NewPatt As Outlook.RecurrencePattern
LogFile = "c:\Outlook.log"
fnum = FreeFile()
Open LogFile For Output As fnum
Print #fnum, "Outlook Birthday Export"
Set olns = ThisOutlookSession.Application.GetNamespace("MAPI")
Set ContactFolder = olns.GetDefaultFolder(olFolderContacts)
Set CalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
Set MyContacts = ContactFolder.Items
Set MyBirthdays = CalendarFolder.Items
For Each Person In MyContacts
If Person.Class = olContact Then
If Year(Person.Birthday) < 4000 Then
foundBirthday = False
For Each Bday In MyBirthdays
If Bday.Class = olAppointment Then
If InStr(Bday.Subject, "Birthday") > 0 And _
Left(Bday.Subject, 5) = Left(Person.FullName, 5) Then
foundBirthday = True
End If
End If
Next Bday
If foundBirthday Then
Print #fnum, Person.FullName; Tab(30); _
Format(Person.Birthday, "dd-mmm-yyyy")
Else
Set NewBday = Outlook.CreateItem(olAppointmentItem)
Set NewPatt = NewBday.GetRecurrencePattern
NewPatt.RecurrenceType = olRecursYearly
NewPatt.PatternStartDate = Person.Birthday
NewPatt.DayOfMonth = Day(Person.Birthday)
NewPatt.MonthOfYear = Month(Person.Birthday)
NewPatt.NoEndDate = True
NewBday.MeetingStatus = olNonMeeting
NewBday.Subject = Person.FullName & "'s Birthday"
NewBday.Start = Person.Birthday
NewBday.AllDayEvent = True
NewBday.BusyStatus = olFree
NewBday.Save
Print #fnum, Person.FullName; Tab(30); _
Format(Person.Birthday, "dd-mmm-yyyy"); _
Tab(50); "Added to calendar"
End If
End If
End If
Next Person
Close #fnum
End Sub