A user wanted to create a macro that would send his upcoming appointments:
1. Each night at 9:00 pm, email me a snapshot of my calendar for the next day2. Each Sunday at 9:00 pm, also email me a snapshot of my calendar for the upcoming week (Mon-Sun).
Do you want pretty or just functional? Outlook's Share > Email Calendar function creates a pretty calendar (it can be automated) or you can create a simple list in an email message. The simple list is not pretty (you can use HTMLBody and tags to pretty it up a little) but does the job. To run the macro automatically, you can use a reminder.
If you want to send the calendar in a message you are composing, you can use the Insert > Calendar command. This adds the pretty calendar and the ICS file to the email you are composing. The macro at Add the .ICS file to a message automates adding the ics file as an attachment.
Pretty Email Agenda
This macro creates a nicely formatted email message, as seen in the screenshot above. I used Free/Busy and Subject for the details. Full Details will include the short list as seen in the screenshot, with the full details below.
Because I'm sending this to myself, I'm removing the .ics file attachment that is normally added to the message.
Public Sub SendPrettyAgenda()
Dim oNamespace As NameSpace
Dim oFolder As Folder
Dim oCalendarSharing As CalendarSharing
Dim objMail As MailItem
Dim wd As Integer
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oCalendarSharing = oFolder.GetCalendarExporter
' get the day - send sat/sun/monday out Fri night
' Sun = 1, Mon = 2, Tue = 3, Wed = 4, Thu = 5, Fri = 6, Sat = 7
' none set Sat/Sun
wd = Weekday(Date)
If wd >= 2 And wd <= 7 Then
lDays = Date + 1
ElseIf wd = 1 Then
lDays = Date + 7
End If
With oCalendarSharing
' options are olFreeBusyAndSubject, olFullDetails, olFreeBusyOnly
.CalendarDetail = olFreeBusyAndSubject
.IncludeWholeCalendar = False
.IncludeAttachments = False
.IncludePrivateDetails = True
.RestrictToWorkingHours = False
.StartDate = Date + 1
.EndDate = lDays
End With
' prepare as email
' options: olCalendarMailFormatEventList, olCalendarMailFormatDailySchedule
Set objMail = oCalendarSharing.ForwardAsICal(olCalendarMailFormatDailySchedule)
' Send the mail item to the specified recipient.
With objMail
.Recipients.Add "me@slipstick.com"
' Remove the attached ics
.Attachments.Remove (1)
.Display 'for testing, change to .send
End With
Set oCalendarSharing = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
End Sub
Simple List of Appointments
This macro borrows from the code sample at "How to print a list of recurring dates using VBA" to create a simple list of appointments.
I'm only using the Subject, start and end times in this sample, but you can add any appointment field.
Use HTMLBody and HTML tags to format the list a little better.
Sub CreateListofAppt()
Dim CalFolder As Outlook.MAPIFolder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter, strSubject, strAppt As String
Dim iNumRestricted As Integer
Dim itm, apptSnapshot As Object
Dim tStart As Date, tEnd As Date, tFullWeek As Date
Dim wd As Integer
' Use the default calendar folder
Set CalFolder = Session.GetDefaultFolder(olFolderCalendar)
Set CalItems = CalFolder.Items
' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
CalItems.IncludeRecurrences = True
' Set an end date
tStart = Format(Date + 1, "Short Date")
tEnd = Format(Date + 2, "Short Date")
tFullWeek = Format(Date + 6, "Short Date")
wd = Weekday(Date)
' Sun = 1, Mon = 2, Tues = 3, Wed = 4, Thu = 5, Fri = 6, Sat = 7
' get next day appt, do whole week on sunday
If wd >= 2 And wd <= 6 Then
sFilter = "[Start] >= '" & tStart & "' AND [Start] <= '" & tEnd & "'"
ElseIf wd = 1 Then
sFilter = "[Start] >= '" & tStart & "' AND [Start] <= '" & tFullWeek & "'"
End If
Debug.Print sFilter
Set ResItems = CalItems.Restrict(sFilter)
iNumRestricted = 0
'Loop through the items in the collection.
For Each itm In ResItems
Debug.Print ResItems.Count
iNumRestricted = iNumRestricted + 1
' Create list of appointments
strAppt = strAppt & vbCrLf & itm.Subject & vbTab & " >> " & vbTab & itm.Start & vbTab & " to: " & vbTab & Format(itm.End, "h:mm AM/PM")
Next
' After the last occurrence is checked
' Open a new email message form and insert the list of dates
Set apptSnapshot = Application.CreateItem(olMailItem)
With apptSnapshot
.Body = strAppt & vbCrLf & "Total appointments; " & iNumRestricted
.To = "me@slipstick.com"
.Subject = "Appointments for " & tStart
.Display 'or .send
End With
Set itm = Nothing
Set apptSnapshot = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub
Use Reminders to trigger the macro
To schedule the macro, you can use a reminder to trigger the macro. For more information on this method, see "Send an Email When a Reminder Fires".
This macro needs to go in ThisOutlookSession; either macro above can go into a new module.
Private Sub Application_Reminder(ByVal Item As Object) 'IPM.TaskItem to watch for Task Reminders If Item.MessageClass <> "IPM.Appointment" Then Exit Sub End If If Item.Categories <> "Send Message" Then Exit Sub End If ' call the macro: SendPrettyAgenda ' or ' CreateListofAppt End Sub
Add the .ICS file to a message
This version of the macro will add the ics file to a message you are already composing. It automates using the Insert > Calendar button but will not add the "pretty" formatted list to the message, only adds the ICS file as an attachment.
As written, the calendar is three business days, starting "tomorrow". It shows only free/busy state and only working hours.
To use, add the macro to a button on your ribbon and run it when you need to add your availability to a message.
Public Sub AvailabilityICS()
Dim oNamespace As NameSpace
Dim oFolder As Folder
Dim oCalendarSharing As CalendarSharing
Dim objMail As MailItem ' As Inspector
Dim wd As Integer
Dim lDate As Date
Dim sDtate As Date
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oCalendarSharing = oFolder.GetCalendarExporter
' start date tomorrow
sDtate = Date + 1
' end date is 3 business days
' Sun = 1, Mon = 2, Tue = 3, Wed = 4, Thu = 5, Fri = 6, Sat = 7
wd = Weekday(Date)
If wd >= 1 And wd <= 3 Then
lDate = sDtate + 2
ElseIf wd >= 4 Then
lDate = sDtate + 4
End If
With oCalendarSharing
' options are olFreeBusyAndSubject, olFullDetails, olFreeBusyOnly
.CalendarDetail = olFreeBusyOnly
.IncludeWholeCalendar = False
.IncludeAttachments = False
.IncludePrivateDetails = False
.RestrictToWorkingHours = True
.StartDate = sDtate
.EndDate = lDate
End With
SaveAsPath = "D:\Availability from " & Format(sDtate, "mmm dd - ") & Format(lDate, "mmm dd yyyy") & ".ics"
oCalendarSharing.SaveAsICal SaveAsPath
Set objMail = Application.ActiveInspector.CurrentItem
' Send the mail item to the specified recipient.
With objMail
.Attachments.Add SaveAsPath
.Display
End With
Set oCalendarSharing = Nothing
Set oFolder = Nothing
Set oNamespace = Nothing
End Sub
How to use the macros on this page
First: You need to have macro security set to low during testing. The macros will not work otherwise.
To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
Darren says
How do I make this work with the fire email on reminder script too?
Darren says
How can I add the .ics attachment (I would like to just send all my meetings for that current day till Friday) to the Send email on reminder fire?
miguel says
Hi there the code works very well, thanks very much for sharing, I have a question, I manage 2 different calendars at the same time, is there a way I can select which calendar I need to share, I am using the "SendPrettyAgenda" code
thanks so mouch again for sharing
Claire Purbrick says
Hi! This is great and really helpful. I manage another person's calendar. Is there a way to run a macro like this for this other person's calendar? Is there a way to add who has accepted or declined a meeting?
Many Thanks!
Diane Poremsky says
You can, but may only be able to send a simple list, not the pretty agenda.
Tio run it manually, change
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oFolder = Application.ActiveExplorer.CurrentFolder.
to automate it, you need use the shared mailbox name -
Set oFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
The full code and instructions are here -
https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#shared
Jeff says
What can I add to the Reminders to trigger a macro that will automatically dismiss the reminder? I tried adding part of the dismiss reminder script from "Send an Email When a Reminder Fires", but it errors out.
Darren says
Andy says
I manage a conference room that remains locked. About 30 minutes before a meeting I email our security asking them to unlock the door. I'm looking for a way to have that automated. I used the 'Use reminders to trigger macro' and the Pretty email agenda' macro which worked great and sent me the agenda. How do I add text to that email to ask security to unlock the door for the extent of the meeting?
Kiwi says
Hi,
Thank you for sharing, it's really helpful.
Is it possible to add a condition if any appointment falls before a certain time? i.e. I would like to be notified if I have a meeting before I start work or starting within the first 15 minutes (09:00-09:15).
Many thanks!
RXN says
Hello,
This is very, very helpful.
However, I'm very new to VBA and was wondering what changes would need to be made in order to adjust this script so that it creates a snapshot only of Today's calendar and it doesn't even need to send anything automatically.
My plan is to have QAT macro that will open new email with the snapshot of my today's calendar.
I attempted to do this on my own but I haven't had much success.
Lyn Williams says
Will this work on a shared calendar? If so, how?
Also, I get a runtime error for line 35 concerning objMail... it says it's impossible to export.
Any solutions?
Diane Poremsky says
It *should* work on a shared (or any non-default calendar) - just need to properly identify it in this line:
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
You'll need to use the code at https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#shared to get the owner.
Set oFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
I cant repro the error - what type of email account do you use?
Diane Poremsky says
This macro works here on a shared mailbox -
Public Sub SendPrettyAgenda()Dim oNamespace As NameSpace
Dim oFolder As Folder
Dim oCalendarSharing As CalendarSharing
Dim objMail As MailItem
Dim wd As Integer
Dim objOwner As Outlook.Recipient
Set oNamespace = Application.GetNamespace("MAPI")
Set objOwner = oNamespace.CreateRecipient("olsales")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set oFolder = oNamespace.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
Set oCalendarSharing = oFolder.GetCalendarExporter
' get the day - send sat/sun/monday out Fri night
' Sun = 1, Mon = 2, Tue = 3, Wed = 4, Thu = 5, Fri = 6, Sat = 7
' none set Sat/Sun
wd = Weekday(Date)
If wd >= 2 And wd <= 7 Then lDays = Date + 1 ElseIf wd = 1 Then lDays = Date + 7 End IfWith oCalendarSharing ' options are olFreeBusyAndSubject, olFullDetails, olFreeBusyOnly .CalendarDetail = olFreeBusyAndSubject .IncludeWholeCalendar = False .IncludeAttachments = False .IncludePrivateDetails = True .RestrictToWorkingHours = False .StartDate = Date + 1 .EndDate = lDays End With' prepare as email ' options: olCalendarMailFormatEventList, olCalendarMailFormatDailySchedule Set objMail = oCalendarSharing.ForwardAsICal(olCalendarMailFormatDailySchedule) ' Send the mail item to the specified recipient. With objMail .Recipients.Add "me@slipstick.com"' Remove the attached ics .Attachments.Remove (1) .Display 'for testing, change to .send End WithSet oCalendarSharing = Nothing Set oFolder = Nothing Set oNamespace = Nothing End Sub
Dan says
Hi Diane, many thanks for sharing! Can I check for shared calendar, is there a way we can modify the macro for the reminders to trigger the macro, since the shared calendar will not send the reminders to me?
WCR says
Hello, my pc does not sleep or hibernate, but does lock, after a certain period of time. I have adjusted the code to send this agenda at 745 am. But it is not sending. Is that because the reminders do not execute while the PC is locked? Any way to make this work without having to keep my pc unlocked at all times?
Diane Poremsky says
It could be because the reminders don't fire. I'll need to think on it, but it might be possible to do it using task scheduler - it can run when locked.
ketan says
Hello Diane,
I have been using all kinds of your code for years now and have gotten some fantastic ideas from you.
Thank you for all the help!
I'm trying to do the 'flip' of what you have above. Meaning, I want to create a list of any appointment slots that are 4 hours long.
It will be clear that I'm not an experienced VBA guy once you look at the code below. Any chance you can help?
Sub FindAppts()
Dim myStart As Date
Dim myEnd As Date
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 farout As Integer
Dim timeperiod As Integer
Dim strappt As String
Dim itm, apptSnapshot As Object
Dim morning As Date, afternoon As Date
Dim counter As Integer
morning = "9:00 AM"
afternoon = "1:00 PM"
evening = "5:30 PM"
farout = InputBox("How many days out?")
myStart = Date + 1
myEnd = DateAdd("d", 50, myStart)
'Construct filter for the next 30-day date range
' strRestriction = "[Start] >= '" & _
'Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
'& "' AND [End] = '" & Format$(myStart + timeperiod & " " & morning, "mm/dd/yyyy hh:mm AMPM") & "' AND [End] > " & morning & vbTab & " to: " & vbTab & afternoon
End If
counter = 0
Next
Set apptSnapshot = Application.CreateItem(olMailItem)
With apptSnapshot
.Body = strappt & vbCrLf
.To = "null@null"
.Subject = "Availability for " & myStart & " to " & myEnd
.Display 'or .send
End With
Set itm = Nothing
Set apptSnapshot = Nothing
Set ResItems=Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub
Diane Poremsky says
Two things stick out - 1) you don't tell it what calendar folder to search 2) if you want to restrict this to user defined dates, use myEnd = DateAdd("d", farout, myStart)
Do you want to only find events at specific times or find all that are at least 4 hours long?
The attached macro is very messy but works here.