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