A reader named Jasmine contacted me last week with an interesting request. Jasmine’s office maintains a shared Outlook calendar used to keep track of vacations. They’d like the ability to send an employee an email a few days before they go on vacation reminding them to change their voice-mail message. Each vacation entry consists of an appointment on the shared calendar. The subject of each appointment uses the form “XXX vacation” where “XXX” is the employee’s initials. Jasmine asked if I could build something that would do this automatically. Here is the solution I put together for her.
I wrote the solution in VBScript so it can run from a scheduled task (i.e. a task in Windows Task Scheduler). When the task executes it will run the script. The script will open Outlook, connect to the shared calendar, retrieve all the appointments for the day X days from now (Jasmine will set the value of X), look through those appointments to find the vacation entries (it identifies them by the word “vacation” appearing in the subject), then create and send a reminder to each vacation entry it found. Because Jasmine’s office uses initials to identify each employee, the script uses a file Jasmine will build to match an employee’s initials to their email address.
Here’s what Jasmine will need to do to use the solution.
- Create a new text file.
- In the new text file enter the initials and email address of each employee in the form XXX,YYY where XXX is the employee’s initials and YYY is the employee’s email address. Be sure there’s no space before or after the comma separating the initials from the address. Each entry goes on a separate line.
- Save the text file. Jasmine may name it anything she wants. She will need to remember where the file is and what she named it.
- Open Notepad.
- Copy the code below and paste it into Notepad.
- Edit the code per the comments I included in it. Jasmine will need to provide the Outlook folder path to the shared calendar, the name and path to the initials file created in step #1, the number of days in advance of an employee going on vacation to send the reminder message, the reminder message’s subject and body.
- Save the file to disk. Jasmine can name it anything she wants as long as the file extension is .vbs.
- Create a task in Windows Task Scheduler.
- Set the task’s action to run this script.
- Set the task to run once a day.
- Set the task to run in the context of an account with an Outlook profile that has access to the shared calendar.
'--> Create some constants 'On the next line edit the path to the calendar containing the vacation entries Const CALENDAR_PATH = "Outlook Data File\Calendar" 'On the next line edit the path to the file containing the initials and corresponding email addresses Const INITIALS_FILE = "C:\Users\David\Documents\TestArea\Initials.txt" 'On the next line edit the number of days in advance of vacation you want the messages to go out. Const DAYS_IN_ADVANCE = 5 'On the next line edit the subject of the messages. This is the subject that will appear on all vacation warning messages. Const MSG_SUBJECT = "Some subject goes here" 'On the next line edit the body of the messages. This is the body that will appear in all vacation warning messages. Const MSG_BODY = "Some message goes here" Const olMailItem = 0 Const olFormatHTML = 2 '--> Create some variables Dim olkApp, olkSes, olkFld, olkLst, olkApt, olkMsg, datStart, datEnd, dicInitials '--> Initialize some variables datStart = DateAdd("d", DAYS_IN_ADVANCE, Date) & " 12:00 AM" datEnd = DateAdd("d", DAYS_IN_ADVANCE, Date) & " 11:59 PM" LoadInitials '--> Connect to Outlook Set olkApp = CreateObject("Outlook.Application") Set olkSes = olkApp.GetNamespace("MAPI") olkSes.Logon olkApp.DefaultProfileName '--> Open the shared Outlook folder Set olkFld = OpenOutlookFolder(CALENDAR_PATH) '--> Get the items from the folder Set olkLst = olkFld.Items olkLst.Sort "[Start]" olkLst.IncludeRecurrences = True Set olkLst = olkLst.Restrict("[Start] >= '" & datStart & "' AND [Start] <= '" & datEnd & "'") '--> Process the items For Each olkApt In olkLst If InStr(1, olkApt.Subject, "vacation") > 0 Then Set olkMsg = olkApp.CreateItem(olMailItem) With olkMsg .Recipients.Add LookupInitials(Left(olkApt,3)) .Recipients.Resolveall .Subject = MSG_SUBJECT .BodyFormat = olFormatHTML .HTMLBody = MSG_BODY .Send End With End If Next '--> Disconnect from Outlook olkSes.Logoff '--> Destroy all objects Set olkMsg = Nothing Set olkApt = Nothing Set olkFld = Nothing Set olkSes = Nothing Set olkApp = Nothing '-- End script WScript.Quit Sub LoadInitials Dim objFSO, objFil, strBuf, arrTmp Set dicInitials = CreateObject("Scripting.Dictionary") Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFil = objFSO.OpenTextfile(INITIALS_FILE) Do Until objFil.AtEndOfStream strBuf = objFil.ReadLine arrTmp = Split(strBuf, ",") dicInitials.Add arrTmp(0), arrTmp(1) Loop objFil.Close Set objFil = Nothing Set objFSO = Nothing End Sub Function LookupInitials(strInitials) If dicInitials.Exists(strInitials) Then LookupInitials = dicInitials.Item(strInitials) Else LookupInitials = "" End If End Function Function OpenOutlookFolder(strFolderPath) 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 = olkSes.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