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