Solved

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

Posted on 2010-08-18
15
720 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
RoboForm Secure Password Management System

RoboForm Everywhere - Superb Browser Support
Windows / Apple / IOS / Android / Linux / Chrome OS
Use different complex passwords everywhere
Best Secure Password Management by far
Synchronize all of your devices instantly
Safe, Secure & Highly Recommended!

 
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

Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

Question has a verified solution.

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

Large Outlook files lead to various unwanted errors and corruption issues. Furthermore, large outlook files can also make Outlook take longer to start-up, search, navigate, and shut-down. So, In this article, i will discuss a method to make your Out…
In this step by step procedure, you will come to know the details of creating an Outlook meeting in 2007, 2010, 2013 & 2016.
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

734 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