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
Leave a Reply
17 Comments on "Move Appointments to an Archive Calendar"
perfect thanks
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.
Oh, sorry about that. I misunderstood. You want to mark and move the appointments? You need to add this and the getfolderpath function. (It's in the first sample on this page too.)
This can go before the For each..
Set CalFolder = GetFolderPath("ArchiveDone")
And this after the .save but before the End if and Next lines.
objAppt.Move CalFolder
Thanks Diane, .... how do I get the move to work to the sub calendar though? I can't get that to work.
If the subcalendar is in the same data file as the calendar, you'd use
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar).Folders("SharedCal")
instead of
Set objCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Working with other folders
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."
The Keyword was the problem - with that gone the filter works and the macro completes.
I ended up using this filter to speed things up as I have like 1500 appointments and it ran through each - I had added a msgbox location to see what the restriction was returning. :)
strRestriction = "@SQL= (""urn:schemas:httpmail:subject"" LIKE '@Call%' OR ""urn:schemas:httpmail:subject"" LIKE 'C%' AND %last7days(""urn:schemas:calendar:dtstart"")%)"
In this block:
For Each aItem In objCalendar.Items
If Mid(aItem.subject, 1, 2) = "C." Then
you don't identify what an aItem is.
I moved the subject editing code up into the If loop:
objAppt.Categories = "S. CALL MADE."
End If
' my tests had call as the first word
strTemp = Right(objAppt.Subject, (Len(objAppt.Subject) - 5))
objAppt.Subject = strTemp
MsgBox strTemp
iItemsUpdated = iItemsUpdated + 1
objAppt.Save
If the goal of this is to not process previously processed items, you could look for categories. (the location code allows for case variations on the case and spaces at the end.)
If InStr(1, Item.Categories) "Call" Then
If Left(LCase(objAppt.Location), 11) = "missed call" Then
You could check categories in the sql filter code instead of in the loop.
my version is at steve-macro.txt
Yes works fine using SQL simply as I adapted from someone else code.
It's failing here on the SQL (in the macro at least).
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...
On the more regular part - you can set up more tasks with different reminder times. Add code to mark the task complete and save it, and recurring tasks will keep running. Otherwise, you need some way to trigger it since Outlook doesn't have a timer.
I think the code is probably not running, if its waiting for the first code to set the category. What is the full code for the other macro?