I would like to automate this Outlook macro that deletes canceled meetings

This macro deletes all cancelled meetings within two dates.
It runs against the calendar you have open and clicked on.
I would like it to run every 15 minutes against three calendars hard coded into the macro.
I have three meeting room resources, room1, room2 and room3.

Any help would be much appreciated.
Sub CancApt()
    Dim olkFld As Outlook.Folder, _
        olkLst As Outlook.Items, _
        olkItemsInDateRange As Outlook.Items, _
        olkApt As Outlook.AppointmentItem, _
        strRestriction As String, _
        intCnt As Integer, _
        intIdx As Integer, _
        daStart As Date, _
        daEnd As Date
        
    'Enter a start and end date'
    daStart = (DateAdd("d", -7, Date))
    daEnd = (DateAdd("d", 60, Date))
    
    
    'Construct a filter for the date range.
    strRestriction = "[Start] >= '" & daStart _
    & "' AND [End] <= '" & daEnd & "'"
    
    'Select calendar items in current folder
    intAnswer = MsgBox("Have you selected the calendar?", vbYesNo, "Wait")
    If intAnswer = vbYes Then
    Else
        GoTo EndMacro
    End If

    Set olkFld = Application.ActiveExplorer.CurrentFolder
    Set olkLst = olkFld.Items
    
    'To include recurring appointments, sort by using the Start property.
    olkLst.IncludeRecurrences = True
    olkLst.Sort "[Start]"
    
    'Restrict the Items collection.
    Set olkItemsInDateRange = olkLst.Restrict(strRestriction)

    'Loop to count the items'
    For Each olkApt In olkItemsInDateRange
        intCnt = intCnt + 1
    Next
    'Loop to process the items'
    For intIdx = intCnt To 1 Step -1
        Set olkApt = olkItemsInDateRange(intIdx)
        If Left(olkApt.Subject, 9) = "Canceled:" Then
            olkApt.Delete
        End If
    Next
    
EndMacro:
    Set olkFld = Nothing
    Set olkLst = Nothing
    Set olkApt = Nothing
    MsgBox "Purge complete.", vbInformation + vbOKOnly, "Purge Canceled Appointments"
End Sub

Open in new window

LVL 1
RelentimAsked:
Who is Participating?
 
David LeeCommented:
Hi, Relentim.

Outlook doesn't have a built-in scheduling capability for doing this.  The best solution is to convert it from VBA (which runs inside Outlook) to VBScript (which runs outside of Outlook).  You can then create a scheduled task using Windows built-in task scheduler.  I assume if you want it to run automatically you want it to get the right folder and not prompt the user for anything.  Correct?  If so, then I can convert the script.
0
 
quantum_leapCommented:
thisoutlooksession
0
 
RelentimAuthor Commented:
That is exactly what I want, thanks!
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
David LeeCommented:
I think this will do it.  Follow these instructions to use this code.

1.  Open Notepad
2.  Copy the code and paste it into Notepad
3.  Edit the code as needed.  I included comments where things can/need to change
4.  Save the file
5.  Create a scheduled task
6.  Set the task to run every 15 minutes
7.  Set the task to run this script
8.  Set the task to run under your account

Outlook must be open for the script to do its thing.  If Outlook is not open, then the script will simply exit.
Dim olkApp, olkFld, olkLst, olkItemsInDateRange, olkApt, strRestriction, intCnt, intIdx, daStart, daEnd, arrFolders, varFolder

On Error Resume Next
'Get the open instance of Outlook.  If Outlook is not open, then terminate processing.'
Set olkApp = GetObject(,"Outlook.Application")
If TypeName(olkApp) <> "Nothing" Then 
  
	'Enter a start and end date'
	daStart = (DateAdd("d", -7, Date))
	daEnd = (DateAdd("d", 60, Date))
	
	'Construct a filter for the date range.
	strRestriction = "[Start] >= '" & daStart _
	& "' AND [End] <= '" & daEnd & "'"
	
	'Edit the folder paths on the next line.'
	arrFolders = Split("Folder1","Folder2","Folder3")
	For Each varFolder In arrFolders
		Set olkFld = OpenOutlookFolder(varFolder)
		If TypeName(olkFld) <> "Nothing" Then
			Set olkLst = olkFld.Items
			
			'To include recurring appointments, sort by using the Start property.
			olkLst.IncludeRecurrences = True
			olkLst.Sort "[Start]"
			
			'Restrict the Items collection.
			Set olkItemsInDateRange = olkLst.Restrict(strRestriction)
			
			'Loop to count the items'
			For Each olkApt In olkItemsInDateRange
			    intCnt = intCnt + 1
			Next
			
			'Loop to process the items'
			For intIdx = intCnt To 1 Step -1
			    Set olkApt = olkItemsInDateRange(intIdx)
			    If Left(olkApt.Subject, 9) = "Canceled:" Then
			        olkApt.Delete
			    End If
			Next
		End If
	Next
End If
Set olkApp = Nothing
Set olkFld = Nothing
Set olkLst = Nothing
Set olkApt = Nothing
Set olkItemsInDateRange = Nothing
WScript.Quit

Function OpenOutlookFolder(strFolderPath)
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

0
 
David LeeCommented:
This explains folder paths.

A folder path in Outlook is essentially the same as a folder path in the file system.  The one difference being that Outlook folder paths do not include a drive letter.  The path to a folder is a list of all the folders from the root to the target folder with each folder name separated from the preceding folder name by a backslash (i.e. \).  Consider the following folder structure:

Mailbox - Doe, John
    - Calendar
    - Inbox
    - Tasks
Personal Folders
    + Marketing
        + Proposals
        + Reviews
    + Projects
        + Project 1
        + Project 2

The path to "Inbox" is "Mailbox - Doe, John\Inbox".
The path to "Reviews" is "Personal Folders\Marketing\Reviews".
The path to "Project 1" is "Personal Folders\Projects\Project 1".
0
 
RelentimAuthor Commented:
Thanks BlueDevilFan, nearly there!

With one folder path in it works fine.
With two folder paths only the first calendar is affected.
With three folder paths no calendars are touched.

What do you think?

0
 
David LeeCommented:
Can you paste in the line of code with the folder paths so I can see what they look like?
0
 
RelentimAuthor Commented:
Here is how I interpreted your directions
arrFolders = Split("MeetingRoom.1@domain.co.uk\calendar","MeetingRoom.2@domain.co.uk\calendar","MeetingRoom.3@domain.co.uk\calendar")


I have also tried this and only the last folder worked.
arrFolders = Split("MeetingRoom.1@domain.co.uk\calendar, MeetingRoom.2@domain.co.uk\calendar, MeetingRoom.3@domain.co.uk\calendar")
0
 
David LeeCommented:
The first part of the name (i.e. the portion that's to the left of the backslash) is an email address.  That won't work.  Are these calendars in public folders or are they mailboxes?
0
 
RelentimAuthor Commented:
Mailboxes.
This is how they appear in Outlook 2010.
It is working a bit.

I've tried this with no success.
    arrFolders = Split("Mailbox - LastName, FirstName\Calendar")

0
 
David LeeCommented:
My fault.  I don't have the correct syntax for the Split command which we don't want to use anyway.  Line 17 should be

    arrFolders = Array("Mailbox - LastName, FirstName\Calendar","Mailbox - LastName, FirstName\Calendar","Mailbox - LastName, FirstName\Calendar")

Change the names.
0
 
RelentimAuthor Commented:
Excellent, it works.
I had to use email address though. "Mailbox - LastName, FirstName\Calendar" did not work. I think this is an Office 2010 thing?

This is now my line.
arrFolders = Array("MeetingRoom.1@domain.co.uk\calendar","MeetingRoom.2@domain.co.uk\calendar","MeetingRoom.3@domain.co.uk\calendar")
0
 
David LeeCommented:
Ok.  Glad you have it working.
0
 
RelentimAuthor Commented:
Below is the final code.

Dim olkApp, olkFld, olkLst, olkItemsInDateRange, olkApt, strRestriction, intCnt, intIdx, daStart, daEnd, arrFolders, varFolder

On Error Resume Next
'Get the open instance of Outlook.  If Outlook is not open, then terminate processing.'
Set olkApp = GetObject(,"Outlook.Application")
If TypeName(olkApp) <> "Nothing" Then 
  
	'Enter a start and end date'
	daStart = (DateAdd("d", -7, Date))
	daEnd = (DateAdd("d", 60, Date))
	
	'Construct a filter for the date range.
	strRestriction = "[Start] >= '" & daStart _
	& "' AND [End] <= '" & daEnd & "'"
	
	'Edit the folder paths on the next line.'
	arrFolders = Array("Mailbox - Room: Audio Room\Calendar","Mailbox - Room: Board Room\Calendar","Mailbox - Room: Demo Room\Calendar","Mailbox - Room: Directors\Calendar","Mailbox - Room: Glass Room\Calendar")
	For Each varFolder In arrFolders
		Set olkFld = OpenOutlookFolder(varFolder)
		If TypeName(olkFld) <> "Nothing" Then
			Set olkLst = olkFld.Items
			
			'To include recurring appointments, sort by using the Start property.
			olkLst.IncludeRecurrences = True
			olkLst.Sort "[Start]"
			
			'Restrict the Items collection.
			Set olkItemsInDateRange = olkLst.Restrict(strRestriction)
			
			'Loop to count the items'
			For Each olkApt In olkItemsInDateRange
			    intCnt = intCnt + 1
			Next
			
			'Loop to process the items'
			For intIdx = intCnt To 1 Step -1
			    Set olkApt = olkItemsInDateRange(intIdx)
			    If Left(olkApt.Subject, 9) = "Canceled:" Then
			        olkApt.Delete
			    End If
			Next
		End If
	Next
End If
Set olkApp = Nothing
Set olkFld = Nothing
Set olkLst = Nothing
Set olkApt = Nothing
Set olkItemsInDateRange = Nothing
WScript.Quit

Function OpenOutlookFolder(strFolderPath)
    ' Purpose: Opens an Outlook folder from a folder path.'
    ' Written: 4/24/2009'
    ' Author:  BlueDevilFan'
    ' Outlook: All versions'
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Open in new window

0
 
RelentimAuthor Commented:
When defining the folder (calendar) names depending on what version of Outlook you are using you will need to define them differently.

Outlook 2007: "Mailbox - Mailbox Name\Calendar"
Outlook 2010: "Mailbox.Name@domain.co.uk"
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.