Do you keep birthdays in an MS Access database? Or any other database, for that matter? Have you wanted to get them into recurring Outlook appointments so you could remind yourself of the birthdays? Were you too lazy to enter them manually?

Here’s VBA code to automate a one-time addition of them into Outlook.

A few notes:
1. You’ll need to be familiar with the VBA programming environment. If you are in Outlook, alt-F11 gets you there fast.

2. Outlook VBA projects appear to be stored in a single file. Makes sense because Outlook does not fit the document based approach of Excel and Word. However, you can import and export projects, and I’m sure there is a way to control the location of the Outlook project if you really want to.

3. Be sure to have the DAO library references on in order for this to work. A default Outlook VBA project won’t have these turned on. You do this in the VBA IDE by choosing Tools – References and searching for the DAO library and checking it off.

Here’s the code.

Sub add_bdays()
Dim the_sql As String
Dim myDB
Dim ol
Dim myItem
Dim body_text As String

' Here's my SQL statement. Yours will vary, of course.
' Note the format command needed to order dates within the year.
the_sql = "SELECT Format([DOB],""mm/dd"") AS month_day, MainList.DOB, MainList.DOD, MainList.LName, MainList.FName, MainList.Street1, MainList.Street2, MainList.City, MainList.State, MainList.Zip, MainList.Country, MainList.HPhone, MainList.EMail "
the_sql = the_sql & "FROM MainList "
the_sql = the_sql & "WHERE (((MainList.DOB) Is Not Null)) "
the_sql = the_sql & "ORDER BY Format([DOB],""mm/dd"")"

Set ol = CreateObject("Outlook.Application")
Set myDB = DBEngine.OpenDatabase("D:\path\to_your\database.mdb")

Set rs = myDB.OpenRecordset(the_sql)
rs.MoveFirst

Do Until rs.EOF
Set myItem = ol.CreateItem(olAppointmentItem)
myItem.Subject = "BIRTHDAY: " & rs.fname & " " & rs.lname
myItem.Duration = 1
myItem.Start = CDate(rs.month_day & "/09 9:00:00 AM")
myItem.Location = "Ben's desk"
body_text = myItem.Subject

body_text = body_text & Chr(13) & rs.Street1
body_text = body_text & Chr(13) & rs.Street2
body_text = body_text & Chr(13) & rs.City & ", " & rs.State & " " & rs.Zip
body_text = body_text & Chr(13) & rs.Country
body_text = body_text & Chr(13) & rs.HPhone
body_text = body_text & Chr(13) & rs.Email

myItem.Body = body_text
' Code for setting appointment recurrence.
Set objrecurrence = myItem.GetRecurrencePattern
objrecurrence.RecurrenceType = olRecursYearly

' I found I had to specify when the recurrence start date was. Otherwise the start date got entered incorrectly.

objrecurrence.PatternStartDate = CDate(rs.month_day & "/09")
objrecurrence.PatternEndDate = #12/31/2015#

myItem.ReminderMinutesBeforeStart = 2880
myItem.ReminderSet = True

myItem.Save

Set objrecurrence = Nothing
Set myItem = Nothing
rs.MoveNext
Loop

rs.Close
Set rs = Nothing
Set myItem = Nothing

End Sub
Advertisements