Copy Selected Occurrence to an Appointment

Last reviewed on June 20, 2012   —  No comments yet

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

About Diane Poremsky

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

Please post long or more complicated questions at Outlook forums by

Leave a Reply

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

This site uses XenWord.