The code samples on this page create an appointment from an email message and adds it to a calendar. It's based off of the Convert email to task macro, but we needed the email added to a shared calendar to create a diary of sorts rather than as a Task.
Outlook 2013 and Outlook 2016's Quick Steps can be used to create an appointment but Quick Steps use the default reminder setting (and the default calendar).
This first macro works with open or selected Outlook items and creates a new appointment in a subfolder calendar named Log. The Outlook item is added as an attachment.
To use this macro, paste the code into a module and add a button to the ribbon or Quick Access Toolbar (QAT) in Outlook. The macro will work with either an open or selected item and you'll want to add a button to each item type you want to use it with.
To create an appointment from appointment details in the subject or message body, see Create Appointment From Email Automatically.
Private Sub CreateLogCalendar() Dim Ns As Outlook.NameSpace Dim objApp As Outlook.Application Dim olAppt As Outlook.AppointmentItem Dim Item As Object ' works with any outlook item Set Ns = Application.GetNamespace("MAPI") Set objApp = Application 'On Error Resume Next Select Case TypeName(objApp.ActiveWindow) Case "Explorer" Set Item = objApp.ActiveExplorer.selection.Item(1) Case "Inspector" Set Item = objApp.ActiveInspector.CurrentItem End Select ' Subfolder named 'Log' under calendar Set calFolder = Ns.GetDefaultFolder(olFolderCalendar).Folders("Log") Set olAppt = calFolder.Items.Add(olAppointmentItem) With olAppt .Subject = Item.Subject .Attachments.Add Item '.Body = Item.Body .Start = Now '.End = Now .ReminderSet = False .BusyStatus = olFree .Save .Display 'show to add notes End With Set objApp = Nothing Set Ns = Nothing End Sub
Save Message as Appointment
This code sample creates a new appointment on your default calendar and pastes the body of the selected message into the appointment's note's field.
It uses the Word object model; you'll need to set a reference to the Word Object Model in Tools, References.
Sub ConvertMessageToAppointment() Dim objAppt As Outlook.AppointmentItem Dim objMail As Outlook.MailItem Dim objInsp As Inspector Dim objDoc As Word.Document Dim objSel As Word.Selection Set objMail = Application.ActiveExplorer.Selection.Item(1) If Not objMail Is Nothing Then If objMail.Class = olMail Then Set objInsp = objMail.GetInspector If objInsp.EditorType = olEditorWord Then Set objDoc = objInsp.WordEditor Set objWord = objDoc.Application Set objSel = objWord.Selection With objSel .WholeStory .Copy End With End If End If End If Set objAppt = Application.CreateItem(olAppointmentItem) Set objInsp = objAppt.GetInspector Set objDoc = objInsp.WordEditor Set objSel = objDoc.Windows(1).Selection With objAppt .Subject = objMail.Subject .Categories = "From Email" objSel.PasteAndFormat (wdFormatOriginalFormatting) '.Attachments.Add objMail '.Save .Display End With objMail.Categories = "Appt" & objMail.Categories Set objAppt = Nothing Set objMail = Nothing End Sub
Save the Appointment to a Shared Calendar
This version of the macro moves the resulting appointment to a Calendar in a shared mailbox or different data file.
To use this macro, you also need the GetFolderPath function from this page.
Select a message then run the macro to create an appointment in the designated calendar.
February 8 2015 updated code to work with a single selected message, not all messages in a selection.
Sub ConvertMailtoAccountAppt() Dim objAppt As Outlook.AppointmentItem Dim objMail As Outlook.MailItem Set objAppt = Application.CreateItem(olAppointmentItem) Set CalFolder = GetFolderPath("mailbox-name\Calendar") Set objMail = Application.ActiveExplorer.Selection.Item(1) With objAppt .Subject = objMail.Subject 'sets it for tomorrow at 9 AM .Start = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #9:00:00 AM# .Body = objMail.Body .Save .Move CalFolder End With Set objAppt = Nothing Set objMail = Nothing End Sub
To create the appointment using the message's received time, use
objAppt.Start = objMail.ReceivedTime
Create a meeting with the recipients
This version of the code creates a new meeting with the sender and recipients of the message, with the CC'd recipients listed as optional attendees.
Yes, Outlook includes a command to create a meeting with the recipients of the current message, but everyone is placed in the Required field.
Sub ConvertMailtoMeeting() Dim objAppt As Outlook.AppointmentItem Dim objMail As Outlook.MailItem Dim objRecip As Outlook.Recipients Dim myAttendee As Outlook.Recipient Dim strAddress As String Dim x As Long Dim myCounter As Integer 'On Error Resume Next Set objAppt = Application.CreateItem(olAppointmentItem) objAppt.MeetingStatus = olMeeting ' Set CalFolder = GetFolderPath("firstname.lastname@example.org\Calendar") Set objMail = Application.ActiveExplorer.Selection.Item(1) Set objRecip = objMail.Recipients Debug.Print objRecip.Count myCounter = objRecip.Count strAddress = objMail.SenderEmailAddress Set myAttendee = objAppt.Recipients.Add(strAddress) myAttendee.Type = olRequired For x = 1 To myCounter strAddress = objMail.Recipients(x).Address Set myAttendee = objAppt.Recipients.Add(strAddress) Select Case objMail.Recipients(x).Type Case 1 myAttendee.Type = olRequired Case 2 myAttendee.Type = olOptional End Select Next x objAppt.Subject = objMail.Subject 'sets it for tomorrow at 9 AM objAppt.Start = DateSerial(Year(Now), Month(Now), Day(Now) + 1) + #9:00:00 AM# objAppt.Body = objMail.Body ' objAppt.Save 'objAppt.Move CalFolder objAppt.Display Set objAppt = Nothing Set objMail = Nothing End Sub
Create an appointment for messages you send
This macro watches the Sent Items Folder for new items and creates an appointment in a subfolder of the default calendar.
Use an If statement as the first line of the olSent_ItemAdd macro to filter messages, such as create an appointment only if assigned to the category "Appt". (Note that unless you use Exchange server, categories are sent with messages.)
If Item.Categories <> "Appt" Then Exit Sub
Copy and paste the following code into ThisOutlookSession then restart Outlook.
You can use this code to watch the Inbox (change the Set olSent line to use olFolderInbox) and use an If statement to look for specific items. The incoming messages need to contain the appointment data in an uniform format. A code sample using a specially-crafted subject line and one using regex are available at
Dim WithEvents olSent As Items Dim WithEvents calFolder As Outlook.Folder Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set olSent = NS.GetDefaultFolder(olFolderSentMail).Items Set calFolder = NS.GetDefaultFolder(olFolderCalendar).Folders("Test") Set NS = Nothing End Sub Private Sub olSent_ItemAdd(ByVal Item As Object) Dim objAppt As Outlook.AppointmentItem Set objAppt = calFolder.Items.Add(olAppointmentItem) With objAppt .Subject = Item.Subject .Start = Now .Body = Item.Body .Save End With Set objAppt = Nothing End Sub
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s 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