JoeG
New Member
- Outlook version
- Outlook 2016 64 bit
- Email Account
- POP3
Hello,
I have a client who likes to delete old recurring appointments after the month has passed. Because she handpicks the ones to delete, it would be too large a task (no pun intended) to write a macro to just delete all old appointments from previous months on her Outlook calendar.
Her current solution is to select a recurring appointment on the calendar and then open it and reset the start date to the new month (which effectively removes all the old appointments prior to that date.)
One requirement is that only the currently-selected (highlighted) appointment in her calendar is the one she wants to clear previous entries for.
I thought of several approaches to automating this task which included:
1) Finding all occurrences prior to the new start date she picks (the pattern-start-date) and deleting those.
2) Mimicking her process with code by changing the pattern start date to the first day of the next month and saving the changes.
3) Using send-keys to open the dialog box and mimic her keystrokes.
4) Copying the appointment to a new recurring appointment with a different start date and then deleting the old recurring appointment.
I settled on item #2. I got the code to work (some of the time) and that is where I'm stuck.
Let's say her recurring appointment is a daily appointment to go to the store to open the doors for the customers at 9:00 am. This recurring appointment started on 2/15/18 and shows up on her calendar each day at 9:00 am as 'Open Storefront Doors". Now that it's March, she will want to change the pattern start date to 3/1/18. So all the February and older dates will disappear.
When I test the code (listed below), I select one of the February appointments and then run the macro and it successfully changes the pattern start date to 3/1/18. No more items exist in February. When I run it a second time by selecting one of the dates in March, it moves the start date to April 1st. So far, so good. However, when I try to change April to May 1st, the program fails on the Save method. The error is something like, "you changed one of the recurrences and this item no longer exists".
Anyone have some thoughts on what I'm missing here? The weird thing is sometimes the Save method is needed and other times it isn't. (When the code is run, note that we are not opening the recurring appointment but merely highlighting it.)
Here's the basic code. I know there are a few things such as error handling, etc. missing but this is the core routine:
Option Explicit
Public Sub DeleteSelectedRecurringAppointments()
Dim olApp As Outlook.Application
Dim olItem As Object
Dim oAppointment As AppointmentItem
Dim oPattern As RecurrencePattern
Dim olSel As Outlook.Selection
Dim fFound As Boolean
Dim sAppointmentOldPatternStartDate
Dim sAppointmentNewPatternStartDate
Dim sAppointmentDate
Dim sAppointmentSubject
Dim sAppointmentLocation
Dim sAppointmentDetails
Dim x As Long
Set olApp = CreateObject("outlook.application")
Set olSel = olApp.ActiveExplorer.Selection
fFound = False
For Each olItem In olSel
If olItem.Class = olAppointment Then
fFound = True
Set oAppointment = olItem
Set oPattern = oAppointment.GetRecurrencePattern
If oAppointment.IsRecurring Then
fFound = True
With oAppointment
If .Subject <> "" Then
sAppointmentSubject = "Subject: " + .Subject + vbCr
End If
If Not IsNull(.Start) And .Start <> 0 Then
sAppointmentDate = "Appointment Date: " + CStr(Format(.Start, "ddddd h:nn AMPM")) + vbCr
End If
If Not IsNull(oPattern.PatternStartDate) And oPattern.PatternStartDate <> 0 Then
sAppointmentOldPatternStartDate = "Old Series Start Date: " + CStr(Format(oPattern.PatternStartDate, "ddddd h:nn AMPM")) + vbCr
End If
If Not IsNull(oPattern.PatternStartDate) And oPattern.PatternStartDate <> 0 Then
sAppointmentNewPatternStartDate = "New Series Start Date: " + CStr(Format(GetNextMonthFirstDay(oPattern.PatternStartDate), "ddddd h:nn AMPM")) + vbCr
End If
If .Location <> "" Then
sAppointmentLocation = "Location: " + .Location + vbCr
End If
If Trim(.Body) <> "" And Len(.Body) < 2 Then
sAppointmentDetails = "Details: " + Trim(.Body) + vbCr
End If
x = MsgBox("Move up this selected recurring appointment?" + vbCr + vbCr + sAppointmentSubject + sAppointmentDate + sAppointmentLocation + sAppointmentDetails + vbCr + sAppointmentOldPatternStartDate + sAppointmentNewPatternStartDate, vbYesNoCancel + vbQuestion + vbDefaultButton2)
Select Case x
Case vbYes
oPattern.PatternStartDate = Format(GetNextMonthFirstDay(oPattern.PatternStartDate), "ddddd h:nn AMPM")
.Save
Case vbCancel
End
End Select
End With
End If
End If
Next olItem
If fFound = False Then
MsgBox "No appointments were selected.", vbOKOnly + vbInformation
End If
Exit Sub
ErrHandler:
MsgBox Err.Description
End
Return
End Sub
Public Function GetNextMonthFirstDay(dtmDate As Date) As Date
Dim iOldMonth As Integer
Dim iNewMonth As Integer
Dim iOldYear As Integer
Dim iNewYear As Integer
iOldMonth = Month(dtmDate)
iOldYear = Year(dtmDate)
If iOldMonth = 12 Then
iNewMonth = 1
iNewYear = iOldYear + 1
Else
iNewMonth = iOldMonth + 1
iNewYear = iOldYear
End If
GetNextMonthFirstDay = CDate(CStr(iNewMonth) + "/01/" + CStr(iNewYear))
End Function
I have a client who likes to delete old recurring appointments after the month has passed. Because she handpicks the ones to delete, it would be too large a task (no pun intended) to write a macro to just delete all old appointments from previous months on her Outlook calendar.
Her current solution is to select a recurring appointment on the calendar and then open it and reset the start date to the new month (which effectively removes all the old appointments prior to that date.)
One requirement is that only the currently-selected (highlighted) appointment in her calendar is the one she wants to clear previous entries for.
I thought of several approaches to automating this task which included:
1) Finding all occurrences prior to the new start date she picks (the pattern-start-date) and deleting those.
2) Mimicking her process with code by changing the pattern start date to the first day of the next month and saving the changes.
3) Using send-keys to open the dialog box and mimic her keystrokes.
4) Copying the appointment to a new recurring appointment with a different start date and then deleting the old recurring appointment.
I settled on item #2. I got the code to work (some of the time) and that is where I'm stuck.
Let's say her recurring appointment is a daily appointment to go to the store to open the doors for the customers at 9:00 am. This recurring appointment started on 2/15/18 and shows up on her calendar each day at 9:00 am as 'Open Storefront Doors". Now that it's March, she will want to change the pattern start date to 3/1/18. So all the February and older dates will disappear.
When I test the code (listed below), I select one of the February appointments and then run the macro and it successfully changes the pattern start date to 3/1/18. No more items exist in February. When I run it a second time by selecting one of the dates in March, it moves the start date to April 1st. So far, so good. However, when I try to change April to May 1st, the program fails on the Save method. The error is something like, "you changed one of the recurrences and this item no longer exists".
Anyone have some thoughts on what I'm missing here? The weird thing is sometimes the Save method is needed and other times it isn't. (When the code is run, note that we are not opening the recurring appointment but merely highlighting it.)
Here's the basic code. I know there are a few things such as error handling, etc. missing but this is the core routine:
Option Explicit
Public Sub DeleteSelectedRecurringAppointments()
Dim olApp As Outlook.Application
Dim olItem As Object
Dim oAppointment As AppointmentItem
Dim oPattern As RecurrencePattern
Dim olSel As Outlook.Selection
Dim fFound As Boolean
Dim sAppointmentOldPatternStartDate
Dim sAppointmentNewPatternStartDate
Dim sAppointmentDate
Dim sAppointmentSubject
Dim sAppointmentLocation
Dim sAppointmentDetails
Dim x As Long
Set olApp = CreateObject("outlook.application")
Set olSel = olApp.ActiveExplorer.Selection
fFound = False
For Each olItem In olSel
If olItem.Class = olAppointment Then
fFound = True
Set oAppointment = olItem
Set oPattern = oAppointment.GetRecurrencePattern
If oAppointment.IsRecurring Then
fFound = True
With oAppointment
If .Subject <> "" Then
sAppointmentSubject = "Subject: " + .Subject + vbCr
End If
If Not IsNull(.Start) And .Start <> 0 Then
sAppointmentDate = "Appointment Date: " + CStr(Format(.Start, "ddddd h:nn AMPM")) + vbCr
End If
If Not IsNull(oPattern.PatternStartDate) And oPattern.PatternStartDate <> 0 Then
sAppointmentOldPatternStartDate = "Old Series Start Date: " + CStr(Format(oPattern.PatternStartDate, "ddddd h:nn AMPM")) + vbCr
End If
If Not IsNull(oPattern.PatternStartDate) And oPattern.PatternStartDate <> 0 Then
sAppointmentNewPatternStartDate = "New Series Start Date: " + CStr(Format(GetNextMonthFirstDay(oPattern.PatternStartDate), "ddddd h:nn AMPM")) + vbCr
End If
If .Location <> "" Then
sAppointmentLocation = "Location: " + .Location + vbCr
End If
If Trim(.Body) <> "" And Len(.Body) < 2 Then
sAppointmentDetails = "Details: " + Trim(.Body) + vbCr
End If
x = MsgBox("Move up this selected recurring appointment?" + vbCr + vbCr + sAppointmentSubject + sAppointmentDate + sAppointmentLocation + sAppointmentDetails + vbCr + sAppointmentOldPatternStartDate + sAppointmentNewPatternStartDate, vbYesNoCancel + vbQuestion + vbDefaultButton2)
Select Case x
Case vbYes
oPattern.PatternStartDate = Format(GetNextMonthFirstDay(oPattern.PatternStartDate), "ddddd h:nn AMPM")
.Save
Case vbCancel
End
End Select
End With
End If
End If
Next olItem
If fFound = False Then
MsgBox "No appointments were selected.", vbOKOnly + vbInformation
End If
Exit Sub
ErrHandler:
MsgBox Err.Description
End
Return
End Sub
Public Function GetNextMonthFirstDay(dtmDate As Date) As Date
Dim iOldMonth As Integer
Dim iNewMonth As Integer
Dim iOldYear As Integer
Dim iNewYear As Integer
iOldMonth = Month(dtmDate)
iOldYear = Year(dtmDate)
If iOldMonth = 12 Then
iNewMonth = 1
iNewYear = iOldYear + 1
Else
iNewMonth = iOldMonth + 1
iNewYear = iOldYear
End If
GetNextMonthFirstDay = CDate(CStr(iNewMonth) + "/01/" + CStr(iNewYear))
End Function
