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

  newAppt.Display

  Set newAppt = Nothing

Else
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
   Next

   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Written by

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 Outlookforums.

Leave a Reply

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