Last reviewed on June 20, 2012   —  No Comments

Applies to Microsoft Outlook 2010, Outlook 2007, Outlook 2003, Outlook 2002

This VBA will copy the selected appointment. Use it to copy recurring events as single appointments to take notes so you can avoid editing the occurrence.

This creates an appointment from the selected occurrence. This code can be used either by selecting a recurring appointment in the Calendar or by opening the occurrence, then running the macro.

You can use VBA to convert a series to individual appointments. See Copy Recurring Appointment Series to Appointments for the code. If you just need a list of dates, see How to print a list of recurring dates using VBA.

Copy Recurring Appointment Code

Public Sub CopyRecurring()

Dim oAppt As Outlook.AppointmentItem
Dim newAppt As Outlook.AppointmentItem

If TypeName(ActiveExplorer.Selection.Item(1)) = "AppointmentItem" Then
 Set oAppt = GetCurrentItem()

Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)

  newAppt.Start = oAppt.Start
  newAppt.End = oAppt.End
  newAppt.Subject = oAppt.Subject & "(Copy)"
  newAppt.Body = oAppt.Body
  newAppt.Location = oAppt.Location
  newAppt.Categories= oAppt.Categories

  If oAppt.Attachments.Count > 0 Then
    CopyAttachments oAppt, newAppt
  End If


  Set newAppt = Nothing

MsgBox "Sorry, you need to select an appointment"
End If

End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.currentItem
    End Select
    Set objApp = Nothing
End Function

Sub CopyAttachments(objSourceItem, objTargetItem)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
   strPath = fldTemp.Path & "\"
   For Each objAtt In objSourceItem.Attachments
      strFile = strPath & objAtt.FileName
      objAtt.SaveAsFile strFile
      objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
      fso.DeleteFile strFile

   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Leave a Reply

Please post long or more complicated questions at OutlookForums by

If the Post Comment button disappears, press your Tab key.