Automate out-of-office messages in Outlook with Visual Basic for Applications (VBA)

• Author
• Recent Posts

Ben Norcutt

Ben Norcutt is a Microsoft Certified IT Professional (MCITP) with 13 years experience inIT administration in educational establishments.

Latest posts by Ben Norcutt (see all)

• Automate out-of-office messages in Outlook with Visual Basic for Applications (VBA) - Fri, Jan 5 2018
• Add a signature to Office 365 emails with PowerShell - Mon, Nov 11 2013
• Restore Administrative Unlock to Windows 7 - Fri, Oct 4 2013

Note that I've only tested the code with Outlook on Windows 10. Once you understand how my script works, you can adapt it easily to your environment.

I run the script in two ways:

1. I have a button on my toolbar that calls the macro, checks the current day for any out-of-office appointments, and then sets my OoO status accordingly.
2. When Outlook exits, it checks the current day. If it's Friday, it checks for any OoO appointments on Monday and sets the OoO status accordingly. If it’s not Friday, it just checks the next day.

Before using my script, I recommend going into your Outlook out-of-office settings (File > Info > Automatic Replies) and adding a generic OoO message, something along the lines of "I'm currently out of the office and will respond upon my return."

Outlook out of office settings

The current code pops up message boxes to inform you what the script is doing, but you could comment those out to make the script completely silent.

To get started using the code:

1. Start Outlook.
2. Press Alt + F11 to open the Visual Basic Editor.
3. If not already expanded, expand Microsoft Office Outlook Objects.
4. If not already expanded, expand Modules.
5. Select an existing module (such as Module1) by double-clicking it, or create a new module by right-clicking Modules and selecting Insert > Module.
6. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook's VB Editor window.
7. Click the diskette icon on the toolbar to save the changes.
8. Close the VB Editor.

Below is the complete VBA code. I added comments to help you understand what the script is doing:

Private Sub Application_Startup()
'Prompts the user to enable macros as Outlook starts up
Dim Startup As Integer
'Startup = 1
End Sub
Sub WhatToDo(checkDays As Integer)
 'Which day are we looking at, i.e 1 current day, 2 tomorrow
‘Called by our macros linked to the toolbar button and also our Outlook exit macro
On Error GoTo eh
AreWeConnected = Are_We_Connected()
If AreWeConnected = False Then End
OutofOfficeEnabled = Check_Out_Of_Office()
SetOutofOffice = FindOOOAppts(checkDays)
If AreWeConnected = True And OutofOfficeEnabled = False And SetOutofOffice = False Then Action = 1
If AreWeConnected = True And OutofOfficeEnabled = False And SetOutofOffice = True Then Action = 2
If AreWeConnected = True And OutofOfficeEnabled = True And SetOutofOffice = True Then Action = 3
If AreWeConnected = True And OutofOfficeEnabled = True And SetOutofOffice = False Then Action = 4
Select Case Action
    Case 1
        strMsg = "Warning:" & vbCrLf & "Do Nothing"
        nRes = MsgBox(strMsg, vbExclamation, "Out of Office")
        'Do Nothing
    Case 2
        strMsg = "Warning:" & vbCrLf & "About to enable out of office setting"
        nRes = MsgBox(strMsg, vbExclamation, "Auto Out of Office")
        OutOfOffice True
    Case 3
        strMsg = "Warning:" & vbCrLf & "Do Nothing"
        nRes = MsgBox(strMsg, vbExclamation, "Out of Office")
        'Do Nothing
    Case 4
        strMsg = "Warning:" & vbCrLf & "About to disable out of office"
        nRes = MsgBox(strMsg, vbExclamation, "Out of Office")
        OutOfOffice False
    Case Else
        'Do Nothing
End Select
Exit Sub
eh:
    MsgBox "The following error occurred: " & Err.Description    
End Sub
Sub OutOfOffice(bolState As Boolean)
'Calling this with a state of True enables out of office and calling it with a state of False disables out of office
On Error GoTo eh
    Const PR_OOF_STATE = "http://schemas.microsoft.com/mapi/proptag/0x661D000B"
    Dim olkIS As Outlook.Store, olkPA As Outlook.PropertyAccessor
    For Each olkIS In Session.Stores
        If olkIS.ExchangeStoreType = olPrimaryExchangeMailbox Then
            Set olkPA = olkIS.PropertyAccessor
            olkPA.SetProperty PR_OOF_STATE, bolState
        End If
    Next
    Set olkIS = Nothing
    Set olkPA = Nothing 
Exit Sub
eh:
    MsgBox "The following error occurred: " & Err.Description  
End Sub
Function FindOOOAppts(checkDays As Integer) As Boolean
'Finds all appointments in the set date range that have the out of office flag set
On Error GoTo eh
    Dim oCalendar As Outlook.Folder
    Dim oItems As Outlook.Items
    Dim oItemsInDateRange As Outlook.Items
    Dim oFinalItems As Outlook.Items
    Dim oAppt As Outlook.AppointmentItem
    Dim strRestriction As String
    Dim aCount As Long
    Dim nRes As Integer
    Dim Status As Integer
    Dim myStartDate As Date
    Dim myStart As Date
    Dim myEnd As Date
'Setup our dates
myStartDate = Date
myStart = DateAdd("d", checkDays, myStartDate)
myEnd = DateAdd("d", checkDays, myStartDate)
'Construct filter for the relevant date range
strRestriction = "[End] >= " & Chr(34) & Format$(myEnd, "dd/mm/yyyy") & " 00:01 AM " & Chr(34) & " AND [Start] <= " & Chr(34) & Format$(myStart, "dd/mm/yyyy") & " 12:59 PM" & Chr(34)
                      
    Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
    Set oItems = oCalendar.Items
    
    ' Including recurrent appointments requires sorting by the Start property
    oItems.IncludeRecurrences = True
    oItems.Sort "[Start]"
    
    'Restrict the Items collection for the current day
    Set oItemsInDateRange = oItems.Restrict(strRestriction)
    Set oFinalItems = oItemsInDateRange
    
    'Sort the appointments and count the number with out of office status set
    oFinalItems.Sort "[Start]"
    For Each oAppt In oFinalItems
           If oAppt.BusyStatus = olOutOfOffice Then aCount = aCount + 1
    Next
    
    If aCount > 0 Then
    FindOOOAppts = True
    Else
    FindOOOAppts = False
    End If   
Exit Function
    
eh:
    MsgBox "The following error occurred: " & Err.Description   
End Function
Sub AutoOOO_today()
WhatToDo (0) 'Check for out of office appointments today
End Sub
Function Check_Out_Of_Office() As Boolean
'Checks to see if out of office is already enabled
On Error GoTo eh
Dim oNS As Outlook.NameSpace
Dim oStores As Outlook.Stores
Dim oStr As Outlook.Store
Dim oPrp As Outlook.PropertyAccessor
Set oNS = Outlook.GetNamespace("MAPI")
Set oStores = oNS.Stores
For Each oStr In oStores
If oStr.ExchangeStoreType = olPrimaryExchangeMailbox Then
Set oPrp = oStr.PropertyAccessor
Check_Out_Of_Office = oPrp.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x661D000B")
End If
Next
Exit Function
eh:
    MsgBox "The following error occurred: " & Err.Description
End Function
Function Are_We_Connected() As Boolean
'Checks to see if we're connected to our server as we cannot enable out of office if we're not
On Error GoTo eh
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim oNS As Outlook.NameSpace
Dim oStores As Outlook.Stores
Dim oStr As Outlook.Store
Dim oPrp As Outlook.PropertyAccessor
Dim AreWeConnected As Boolean
Dim OutofOfficeEnabled As Boolean
Dim SetOutofOffice As Boolean
Dim Action As Integer
Dim ExchangeStatus  As OlExchangeConnectionMode
Set olNameSpace = olApp.GetNamespace("MAPI")
ExchangeStatus = olNameSpace.ExchangeConnectionMode
If ExchangeStatus = 700 Then
Are_We_Connected = True
Else
Are_We_Connected = False
End If
Exit Function
eh:
    MsgBox "The following error occurred: " & Err.Description
End Function

We need to put the code that runs when Outlook exits in a slightly different place.

1. Press Alt + F11 to open the Visual Basic Editor.
2. If not already expanded, expand Microsoft Office Outlook Objects.
3. If not already expanded, expand ThisOutlookSession.
4. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook's VB Editor window.
5. Click the diskette icon on the toolbar to save the changes.
6. Close the VB Editor.

Location of the exit code

And this is the exit code:

result = MsgBox("Run Auto Out of Office?", vbYesNo)
    If result = vbYes Then
    If Weekday(Now(), vbMonday) = 5 Then
    MsgBox "Yay it's FRIDAY!!!"
    WhatToDo (3)
Else
    WhatToDo (1)
End If
    Else
        'do nothing
    End If
End Sub

That's the end of all the code required. Each subroutine has comments explaining what it does.

My ribbon button looks like this:

Out of office ribbon button

Clicking it will run the code. In this example, it returns "do nothing" because I have OoO already turned on and there is an OoO appointment today. Following the logic of the what-to-do subroutine, this triggers case 3.

"Do nothing" warning

When I exit Outlook, it asks me if I would like to run Auto Out of Office.

Pop up window when exiting Outlook

It's Friday:

Friday pop up message

Looking ahead to Monday, we trigger case 3 again:

Triggering case 3 again

Starting up Outlook runs the little piece of code we have in Sub Application_Startup(). Due to the default security settings, it prompts the user to enable macros. This is just so I can now hit my ribbon button or shut down Outlook, and it won’t prompt me to enable macros anymore.

Prompt to enable macros