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

Create the appointment using rules

This macro uses a rule to create an appointment from incoming email. The rule should only contain conditions, not Actions. All actions need to be handled by the script. For more information, see Outlook's Rules and Alerts: Run a Script.

Because of limitations in appointments, any html in the message body won't be formatted.

The method used in other macros on this page to copy and paste formatted text wont work here, unless you have the macro open and close the incoming message. If you don't mind the quick flash onscreen as the macro opens and close the messages, I have a macro here that copies and pastes formatted text.

Public Sub ApptFromMail(Item As MailItem)

Dim objAppt As Outlook.AppointmentItem
Set objAppt = Application.CreateItem(olAppointmentItem)

With objAppt
    .Subject = Item.Subject
    .location = "Location"
    .AllDayEvent = True
    .BusyStatus = olBusy
    .Start = Date + 3
    .Body = Item.Body
    .Display
    .Save

End With
    Set objAppt = 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("alias@domain.com\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:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor