Private Sub cmdAddAppointment_Click()
On Error GoTo Add_Err
'Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
'Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment is already added to Microsoft Outlook"
Exit Sub
'Add a new appointment.
Else
Dim objOutlook As Outlook.Application
Dim objAppointment As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Set objOutlook = CreateObject("Outlook.Application")
Set objAppointment = objOutlook.CreateItem(olAppointmentItem)
With objAppointment
.Start = Me!AppointmentDate & " " & Me!AppointmentTime
.Duration = Me!AppointmentLength
.Subject = Me!Appointment
If Not IsNull(Me!AppointmentNotes) Then .Body = Me!AppointmentNotes
If Not IsNull(Me!AppointmentLocation) Then .Location = Me!AppointmentLocation
If Me!AppointmentReminder Then
.ReminderMinutesBeforeStart = Me!ReminderMinutes
.ReminderSet = True
End If
'Set objRecurPattern = .GetRecurrencePattern
'With objRecurPattern
'.RecurrenceType = olRecursWeekly
' .Interval = 1
'Once per week
' .PatternStartDate = #7/9/2003#
'You could get these values
'from new text boxes on the form.
'.PatternEndDate = #7/23/2003#
'End With
.Save
.Close (olSave)
End With
'Release the AppointmentItem object variable.
Set objAppointment = Nothing
End If
'Release the Outlook object variable.
Set objOutlook = Nothing
'Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub