Create task or calendaritem based on open e-mail

Ease of Use


Version tested with


Submitted by:



Add a task or appointment based on open e-mail instead of drag and drop 


With drag and drop you can easily create tasks or appointments from an e-mail. Usually you have opened the mail and read it before you make the decision to create a task or appointment. With this one, you don't have to close the mail. You can create a button on any mail that you open by using this KB article : http://vbaexpress.com/kb/getarticle.php?kb_id=502 by MOS Master and attach this macro (AddCalendarEntry) to the action instead of the included one. 


instructions for use


Option Explicit Public Sub AddCalendarEntry() Const mailItem_c As String = "MailItem" Dim OE As Outlook.Explorer Dim MI As Outlook.MailItem Dim AI As Outlook.AppointmentItem Dim TI As Outlook.TaskItem Set OE = Application.ActiveExplorer 'Abort sub if no item selected: If OE.Selection.Count < 1 Then MsgBox "Please select an already saved message before" & vbCrLf & _ "attempting to create an appointment or task" & vbCrLf & _ "with this button ...", vbInformation, "No message selected ..." Exit Sub 'Abort sub if item selected is not a MailItem. ElseIf TypeName(OE.Selection(1)) <> mailItem_c Then MsgBox "You must select a mail item...", vbInformation, "Invalid selection..." Exit Sub End If Set MI = OE.Selection(1) Beep Select Case MsgBox("Is calendar entry an appointment?" & vbLf & _ "To Add Appointment (Yes) / To Add Task (No) / To Quit (Cancel)" & _ vbCrLf, vbYesNoCancel + vbQuestion, "Create an appointment or task ...") Case vbYes 'If yes, create appointment Set AI = Outlook.CreateItem(olAppointmentItem) With AI .Subject = MI.Subject .Body = MI.Body .Save .Display End With Case vbNo 'If no, create task due with date of today 'and due date is tomorrow at 10:00 am Set TI = Application.CreateItem(olTaskItem) With TI .Subject = MI.Subject .Body = MI.Body .StartDate = Date .DueDate = Date + 1 .ReminderTime = .DueDate & " 10:00" .Save .Display End With 'Case vbCancel ' Exit Sub End Select End Sub

How to use:

  1. open outlook
  2. push alt + f11
  3. find a module or create one with right mouseclick on the left window pane
  4. copy and paste the code in a code module
  5. close the editor (push the red cross)
  6. when saving outlook, save the changes off course
  7. open an e-mail and run this macro

Test the code:

  1. open an e-mail and run this macro (alt + F8)

Sample File:

No Attachment 

Approved by mdmackillop

This entry has been viewed 170 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express