Move Appointments to an Archive Calendar

Last reviewed on December 30, 2013

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

Petros asked

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

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.

17 responses to “Move Appointments to an Archive Calendar”

  1. stephengazard

    Can someone tell me how I could amend this to move appointments of a particular category?

  2. stephengazard

    That's fantastic Diane many thanks .... without pushing my luck how would I get this to run on all items in the calendar rather than just current item? Ideally automatically even.

    Really appreciate your help.

  3. stephengazard

    Thanks Diane, I think I am getting there but struggling a bit .... I have two processes (I am sure the could be shortened to one mind you but everytime I try I break it !) ...

    First process sets category of appointment based on Subject and location (all works ok).

    The second process "MoveCallLog" should (but doesn't) ... move only those appointments that carry the category of "Calls" to a sub calendar called "Call Log"

    I can't get it to work - it either doesn't fire or moves everything!

    Also is there a way to automate more regularly than daily via the task reminder?

    Your help would be MUCH appreciated.

    Code below:

    Private Sub Application_Reminder(ByVal Item As Object)

    If Item.subject = "Move Calls" Then

    Public Sub MoveACallLog()
    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("\stephen@gazard.netCalendarCall Log")

    For i = objAppt.Count To 1 Step -1

    If objAppt(i).Categories = "Calls" Then

    objAppt(i).Move CalFolder
    End If

    Next i

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

    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

  4. stephengazard

    other code:

    Private Sub Application_Reminder(ByVal Item As Object)

    If Item.subject = "Process Calls" Then

    ' Define variables
    Dim objCalendar As Outlook.folder
    Dim objItems As Outlook.Items
    Dim objAppt As Outlook.AppointmentItem
    Dim strRestriction As String
    Dim objFinalItems As Outlook.Items
    Dim myolApp As Outlook.Application

    ' Set strRestriction to be only calls
    strRestriction = "@SQL= (""urn:schemas:httpmail:subject"" LIKE '@Call.%' OR ""urn:schemas:httpmail:subject"" LIKE 'C.%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call in%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call%') AND ""urn:schemas-microsoft-com:office:office#Keywords"" 'Phone call'"

    ' Set the objCalendar and objItems items
    Set objCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    Set objItems = objCalendar.Items
    Set objFinalItems = objItems.Restrict(strRestriction)
    Set myolApp = CreateObject("Outlook.Application")

    For Each objAppt In objFinalItems
    ' Debugging
    ' Debug.Print objAppt.Start, objAppt.Subject, objAppt.Categories
    ' Assign the category to the appointments

    If objAppt.Location = "Missed Call " Then
    objAppt.Categories = "S. CALL MISSED."

    ElseIf objAppt.Location = "Incoming Call " Then
    objAppt.Categories = "S. CALL RECEIVED."

    Else

    objAppt.Categories = "S. CALL MADE."

    End If

    objAppt.Save

    Next

    ' Rename Entry
    Dim iItemsUpdated As Integer
    Dim strTemp As String

    iItemsUpdated = 0

    For Each aItem In objCalendar.Items

    If Mid(aItem.subject, 1, 2) = "C." Then
    strTemp = Mid(aItem.subject, 4, Len(aItem.subject) - 4)
    aItem.subject = strTemp
    iItemsUpdated = iItemsUpdated + 1
    End If
    aItem.Save

    Next aItem

    MsgBox iItemsUpdated & " of " & objCalendar.Items.Count & " Meetings Updated"

    End If

    End Sub

  5. Diane Poremsky

    Does the SQL filter work as expected in custom views? Is there a reason you are using that filter instead of an If statement? If instr( item.subject, "call") then...

  6. stephengazard

    Yes works fine using SQL simply as I adapted from someone else code.

  7. stephengazard

    Really? That part seems to work for me it is the move that doesn't.

    If I wanted to replace the SQL then with an if stmt will tag help?

    All the relevant appointments start with "C."

  8. stephengazard

    Thanks Diane, .... how do I get the move to work to the sub calendar though? I can't get that to work.

  9. stephengazard

    Sorry Diane I am sure I am being dum ... but I've done that but it appears to now run the process on the sub calendar "Call Log" rather than run the process on the default calendar and then move the appointment to the sub calendar on completion.

  10. stephengazard

    perfect thanks

Leave a Reply

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