Copy recurring appointment in outlook with VBA macro - vba

Question

How can I copy a recurring appointment in outlook 2013 with VBA? I've tried copying the RecurrencePattern Object from the source item to the destination item (cAppt), but this sets the start date to the next immediate calendar interval (e.g. if it is 4:12 now, the recurring series is set to start at today at 4:30) instead of the actual start date of the original item. Any hints on how to do this?
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim oPatt As RecurrencePattern
Dim cPatt As RecurrencePattern
Dim moveCal As AppointmentItem
' On Error Resume Next
'only copy items not marked as private
If Item.Sensitivity <> olPrivate Then
Item.Body = Item.Body & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)
If Item.IsRecurring Then
Set cPatt = cAppt.GetRecurrencePattern
cPatt = Item.GetRecurrencePattern
End If
With cAppt
.Subject = Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
End With
' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)
moveCal.Categories = "moved"
moveCal.Save
End If
End Sub

Answer 1

Try to use AppointmentItem.Copy instead of Application.CreateItem.

Answer 2

I know this is a very old post, but I wanted to share my findings on why OP's original VBScript didn't work.
AppointmentItem.Copy can work, but depending on when it's used it can cause VBScript to break (e.g. copying an appointment to a shared calendar automatically when its added to your personal). Application.CreateItem does not have this drawback.
After doing some testing, I can confirm (in Outlook 2016 anyway) that GetRecurrencePattern method captures all relevant attributes except the StartTime property. As a result, the start time is set to a default of the next immediate time frame on your calendar.
To fix this, you can change the script as follows:
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
'Dim oPatt As RecurrencePattern --unnecessary declaration, can delete.
Dim cPatt As RecurrencePattern
Dim moveCal As AppointmentItem
' On Error Resume Next
'only copy items not marked as private
If Item.Sensitivity <> olPrivate Then
Item.Body = Item.Body & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)
If Item.IsRecurring Then
Set cPatt = cAppt.GetRecurrencePattern
cPatt = Item.GetRecurrencePattern
cPatt.StartTime = Item.Start 'Add appointment time as StartTime.
cPatt.Duration = Item.Duration 'need to define Duration (or EndTime) after changing StartTime.
End If
With cAppt
.Subject = Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
End With
' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)
moveCal.Categories = "moved"
moveCal.Save
End If
End Sub
Also, not sure if OP needed to give credit, but credit where credit is due the code is mostly copypasta from http://www.slipstick.com/developer/copy-new-appointments-to-another-calendar-using-vba/