Solved

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

Posted on 2010-08-18
15
718 Views
Last Modified: 2012-05-10
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

0
Comment
Question by:Relentim
  • 7
  • 7
15 Comments
 

Expert Comment

by:quantum_leap
ID: 33463551
thisoutlooksession
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 33463707
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
 
LVL 1

Author Comment

by:Relentim
ID: 33463877
That is exactly what I want, thanks!
0
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
ID: 33464054
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
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
ID: 33464066
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
 
LVL 1

Author Comment

by:Relentim
ID: 33465576
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
 
LVL 76

Expert Comment

by:David Lee
ID: 33465592
Can you paste in the line of code with the folder paths so I can see what they look like?
0
 
LVL 1

Author Comment

by:Relentim
ID: 33465642
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
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
ID: 33465698
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
 
LVL 1

Author Comment

by:Relentim
ID: 33465788
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
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
ID: 33466049
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
 
LVL 1

Author Comment

by:Relentim
ID: 33466295
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
 
LVL 76

Expert Comment

by:David Lee
ID: 33466460
Ok.  Glad you have it working.
0
 
LVL 1

Author Comment

by:Relentim
ID: 33483632
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
 
LVL 1

Author Closing Comment

by:Relentim
ID: 33483636
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

Featured Post

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Follow this checklist to learn more about the 15 things you should never include in an email signature from personal quotes, animated gifs and out-of-date marketing content.
This article will inform Clients about common and important expectations from the freelancers (Experts) who are looking at your Gig.
In this fifth video of the Xpdf series, we discuss and demonstrate the PDFdetach utility, which is able to list and, more importantly, extract attachments that are embedded in PDF files. It does this via a command line interface, making it suitable …
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

776 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question