Download this FREE eBook and learn all you need to get started with Windows Nano Server, including deployment options, remote management
and troubleshooting tips and tricks
Public Function ExportBirthdaysToOutlook() On Error GoTo ErrorHandler Dim fldCalendar As Outlook.Folder Dim appt As Outlook.AppointmentItem Dim strApptName As String Dim dteStartTime As Date Dim dteEndTime As Date Dim strStatus As String Dim lngStatus As Long Set appOutlook = GetObject(, "Outlook.Application") Set nms = appOutlook.GetNamespace("MAPI") Set fldCalendar = nms.GetDefaultFolder(olFolderCalendar) Set dbs = CurrentDb Set rst = dbs.OpenRecordset("tblBirthdays") With rst Do While Not .EOF 'Check that there is an appointment subject strApptName = Nz(![Title]) Debug.Print "Appointment name: " & strApptName If strApptName = "" Then GoTo NextAppt End If 'Create new appointment item in local 'Calendar folder Set appt = fldCalendar.Items.Add appt.Subject = "Birthday Reminder! " & ![Contact] 'strApptName appt.Start = ![Reminder] appt.End = ![Reminder] appt.Location = "" appt.Body = Nz(![Contact] & vbNewLine & "Phone Number: " & ![PhoneNumber] & vbNewLine & ![CompanyName] & vbNewLine & ![Constituency] & vbNewLine & "Date of Birth: " & ![DateofBirth] & vbNewLine & "Current Age: " & ![Age]) appt.Close (olSave) NextAppt: .MoveNext Loop End With MsgBox "Selected birthday records exported to Outlook", vbInformation ErrorHandlerExit: Exit Function ErrorHandler: 'Outlook is not running; open Outlook with CreateObject If Err.Number = 429 Then Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number _ & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Function
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Join the community of 500,000 technology professionals and ask your questions.