Solved

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

Posted on 2010-08-18
15
717 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
Comment Utility
thisoutlooksession
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
Comment Utility
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
Comment Utility
That is exactly what I want, thanks!
0
 
LVL 76

Assisted Solution

by:David Lee
David Lee earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Can you paste in the line of code with the folder paths so I can see what they look like?
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 1

Author Comment

by:Relentim
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Ok.  Glad you have it working.
0
 
LVL 1

Author Comment

by:Relentim
Comment Utility
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
Comment Utility
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

What Is Threat Intelligence?

Threat intelligence is often discussed, but rarely understood. Starting with a precise definition, along with clear business goals, is essential.

Join & Write a Comment

Set OWA language and time zone in Exchange for individuals, all users or per database.
Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
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 …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

728 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now