Move Appointments to an Archive Calendar

This code removes the reminder and categories and moves the appointment to a calendar in an archive folder or a subfolder under the calendar.

I want to be able to do 3 things with just one click of a button:

With a Calendar event selected, I want to:
1) Erase any Reminder (set Reminder to: 'None'),
2) Clear All Categories,
3) Move the event to another calendar (in My Calendars) named "DONE" (where I keep finished-completed things).

Since this is something I do everyday, multiple times a day, I want to save time by having a macro do all those things with one click.

Removing the reminder and clearing categories is as simple as changing the field values. Moving the event is also a simple process , although it requires a function that gets the filepath if the calendar you are moving the event to is not in the default data file.

The code Set CalFolder = GetFolderPath("Archive\Done") moves the appointment to a calendar folder called "Done" in the Archive pst.

Use Set CalFolder = Session.GetDefaultFolder(olFolderCalendar).Folders("Done") to move the appointments to a subfolder of the calendar. Note: if you are moving the item to a subfolder of the data file, you don't need to use the GetFolderPath function.

For more information on folders and data files, see Working with VBA and non-default Outlook Folders.

The GetCurrentItem function detects whether the appointment is selected or opened. For more information, see Outlook VBA: work with open item or selected item.

Public Sub MoveCalendar()

Dim objAppt As Outlook.AppointmentItem
Set objAppt = GetCurrentItem()

' move to a calendar in an archive data file
Set CalFolder = GetFolderPath("Archive\Done")

' change field values here
With objAppt
    .ReminderSet = False
    .Categories = ""
End With

    objAppt.Move CalFolder
 End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
        
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
        
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

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

Move all appointments

This code sample moves all appointments with an End time before "Now", to the archive folder.

Public Sub MoveAllAppointments()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objAppt As Outlook.Items
    Dim objFolder As Outlook.MAPIFolder
 
    On Error Resume Next
 
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
    Set objAppt = objFolder.Items
 
' move to a calendar in an archive data file
Set CalFolder = GetFolderPath("Archive\Done")

For i = objAppt.Count To 1 Step -1
  
If objAppt(i).End < Now Then
         
' change field values here
With objAppt(i)
    .ReminderSet = False
    .Categories = ""
End With

objAppt(i).Move CalFolder
    End If

Next i

    Set objAppt = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing
    Set objNS = Nothing

    
 End Sub