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
stephengazard says
perfect thanks
stephengazard says
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.
Diane Poremsky says
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
stephengazard says
Thanks Diane, .... how do I get the move to work to the sub calendar though? I can't get that to work.
Diane Poremsky says
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
stephengazard says
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."
Diane Poremsky says
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
stephengazard says
Yes works fine using SQL simply as I adapted from someone else code.
Diane Poremsky says
It's failing here on the SQL (in the macro at least).
dporemsky says
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...
stephengazard says
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
stephengazard says
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
Diane Poremsky says
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?
stephengazard says
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.
Diane Poremsky says
You need to tweak it a little to apply to the entire folder- I added a code sample that moves all appointments that ended before 'now'.
stephengazard says
Can someone tell me how I could amend this to move appointments of a particular category?
Diane Poremsky says
Something like this should work -
Public Sub MoveCalendar()
Dim objAppt As Outlook.AppointmentItem
Set objAppt = GetCurrentItem()
If objAppt.categories = "my category" then
' 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 if
End Sub