toddcjohnson
07-20-2011, 05:33 AM
I am writing some code so that our users can create both an AllDayEvent Meeting Request as a notification that they are Out of Office (AllDayEvent=True, ReminderSet=False,ResponseRequested=False, BusyStatus=Free) and a corresponding appointment to block their own calendar (BusyStatus=OutofOffice) at one time.
The code works fine unless it is a recurring appointment. All the occurrences on the senders calendar are correct. However, the first occurrence on the recipients calendar has Reminder=None, but subsequent occurrences are Reminder= 15 minutes.
I have tried everything I know to get them all set the same as the first, but could now use some help.
Thanks,
Todd
Here is the code:
Private Sub Appt_Send(Cancel As Boolean)
'Does this have a OOO/WFH custom property set? This is set by a macro on the Meeting Request form
If Appt.MeetingStatus = olMeeting And Not (Appt.ItemProperties.Item("OOORequest") Is Nothing) Then
Dim new_appt As AppointmentItem
Dim RPOrig As RecurrencePattern
Dim RPNew As RecurrencePattern
Appt.ReminderSet = False
'Create appointment for sender's calendar
Set new_appt = Outlook.Application.CreateItem(olAppointmentItem)
With new_appt
.Subject = Appt.Subject + " appt"
.BusyStatus = olOutOfOffice
.ReminderSet = False
.Start = Appt.Start
.End = Appt.End
.Save
.Send
End With
'If recurring meeting, duplicate recurrence pattern for new appointment
If Appt.IsRecurring Then
Set RPOrig = Appt.GetRecurrencePattern
Set RPNew = new_appt.GetRecurrencePattern
RPNew = RPOrig
new_appt.Save
'Must clear recurrence on original appointment so we have permission to update the AllDayEvent flag
Appt.ClearRecurrencePattern
Appt.Save
End If
new_appt.Send
'Set Appointment to not bother recipients
With Appt
.Subject = .Subject + " meeting"
.ReminderSet = False
.ResponseRequested = False
.ForceUpdateToAllAttendees = True
.AllDayEvent = True 'Must be changed after new_appt created. This flag clears times in date variables
.BusyStatus = olFree 'Keeps from blocking recipients calendars
.Save
End With
'Reset recurrence pattern for original appointment
If new_appt.IsRecurring Then
Set RPOrig = Appt.GetRecurrencePattern
RPOrig = RPNew
Appt.Save
End If
'Release resources
Set new_appt = Nothing
End If
End Sub
The code works fine unless it is a recurring appointment. All the occurrences on the senders calendar are correct. However, the first occurrence on the recipients calendar has Reminder=None, but subsequent occurrences are Reminder= 15 minutes.
I have tried everything I know to get them all set the same as the first, but could now use some help.
Thanks,
Todd
Here is the code:
Private Sub Appt_Send(Cancel As Boolean)
'Does this have a OOO/WFH custom property set? This is set by a macro on the Meeting Request form
If Appt.MeetingStatus = olMeeting And Not (Appt.ItemProperties.Item("OOORequest") Is Nothing) Then
Dim new_appt As AppointmentItem
Dim RPOrig As RecurrencePattern
Dim RPNew As RecurrencePattern
Appt.ReminderSet = False
'Create appointment for sender's calendar
Set new_appt = Outlook.Application.CreateItem(olAppointmentItem)
With new_appt
.Subject = Appt.Subject + " appt"
.BusyStatus = olOutOfOffice
.ReminderSet = False
.Start = Appt.Start
.End = Appt.End
.Save
.Send
End With
'If recurring meeting, duplicate recurrence pattern for new appointment
If Appt.IsRecurring Then
Set RPOrig = Appt.GetRecurrencePattern
Set RPNew = new_appt.GetRecurrencePattern
RPNew = RPOrig
new_appt.Save
'Must clear recurrence on original appointment so we have permission to update the AllDayEvent flag
Appt.ClearRecurrencePattern
Appt.Save
End If
new_appt.Send
'Set Appointment to not bother recipients
With Appt
.Subject = .Subject + " meeting"
.ReminderSet = False
.ResponseRequested = False
.ForceUpdateToAllAttendees = True
.AllDayEvent = True 'Must be changed after new_appt created. This flag clears times in date variables
.BusyStatus = olFree 'Keeps from blocking recipients calendars
.Save
End With
'Reset recurrence pattern for original appointment
If new_appt.IsRecurring Then
Set RPOrig = Appt.GetRecurrencePattern
RPOrig = RPNew
Appt.Save
End If
'Release resources
Set new_appt = Nothing
End If
End Sub