How to Create a task or appointment using VBA Code in outlook 2003

The code for Outook version newer than 2003 can be found here . At this link you can also find few more info on how this code works.
Just copy and paste in an Outlook VBA Module, and then put on the task bar a macro button that calls

NewTaskOrAppoitmentFromMail

How to Create a task or appointment using VBA Code in outlook 2010

Hi,
I have changed the original code at this link to show you how to create either a task or an appointment from an e-mail item.
This is very handy when you want quickly create task/appointment without wasting your time to attach the original mail.
The only problem is that the item is attached at the end of the file. This is due to a bug in Outlook 2008/2010 for which the postion item does not work.
Just copy and paste the code below into an outlook module to make it work.

Sub CreateTaskFromMail()
  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 a 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)
    Set TI = Application.CreateItem(olTaskItem)
    With TI
            .Subject = MI.Subject
            .Body = .Body & vbCrLf & vbCrLf
            .Body = .Body & "-----Original Message-----" & vbCrLf
            .Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
            .Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
            .Body = .Body & "To: " & MI.To & vbCrLf
            .Body = .Body & "Cc: " & MI.CC & vbCrLf
            .Body = .Body & "Subject: " & MI.Subject & vbCrLf
            .Body = .Body & vbCrLf
            .Body = .Body & MI.Body
            '.StartDate = Date
            '.DueDate = Date + 1
            '.ReminderTime = .DueDate & " 10:00"

  
    Select Case MsgBox("Do you want to attach the original mail?" & vbLf, _
       vbYesNoCancel + vbQuestion, "Add Mail as Attachment ...")
    Case vbYes
         TI.Body = "View Original Mail attacched at the bottom" & vbCrLf & TI.Body
         TI.Attachments.Add MI, , 1 'Position does not work. It is a bug in Outlook 2008/2010
         TI.Display
    Case vbNo
         TI.Display
    Case vbCancel
         Exit Sub
    End Select
          
          
         
    End With
  
End Sub



Sub CreateAppointmentFromMail()
    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" & 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)
    Set AI = Outlook.CreateItem(olAppointmentItem)
    With AI
            .Subject = MI.Subject
            .Body = .Body & vbCrLf & vbCrLf
            .Body = .Body & "-----Original Message-----" & vbCrLf
            .Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
            .Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
            .Body = .Body & "To: " & MI.To & vbCrLf
            .Body = .Body & "Cc: " & MI.CC & vbCrLf
            .Body = .Body & "Subject: " & MI.Subject & vbCrLf
            .Body = .Body & vbCrLf
            .Body = .Body & MI.Body
            '.StartDate = Date
            '.DueDate = Date + 1
            '.ReminderTime = .DueDate & " 10:00"

  
    Select Case MsgBox("Do you want to attach the original mail?" & vbLf, _
       vbYesNoCancel + vbQuestion, "Add Mail as Attachment ...")
    Case vbYes
         AI.Body = "View Original Mail attacched at the bottom" & vbCrLf & AI.Body
         AI.Attachments.Add MI, , 1 'Position does not work. It is a bug in Outlook 2008/2010
         AI.Display
    Case vbNo
         AI.Display
    Case vbCancel
         Exit Sub
    End Select
          
          
         
    End With
  
End Sub




Sub NewTaskOrAppoitmentFromMail()
  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("Do you want to create a Task?" & vbLf & _
        "To Add Task (Yes) / To Add Appointment (No) / To Quit (Cancel)" & _
        vbCrLf, vbYesNoCancel + vbQuestion, "Create a task or appointment ...")
    Case vbNo 'If No, create appointment
        Set AI = Outlook.CreateItem(olAppointmentItem)
        With AI
            .Subject = MI.Subject
            .Body = "View Original Mail attacched at the bottom"
            .Body = .Body & vbCrLf & vbCrLf
            .Body = .Body & "-----Original Message-----" & vbCrLf
            .Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
            .Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
            .Body = .Body & "To: " & MI.To & vbCrLf
            .Body = .Body & "Cc: " & MI.CC & vbCrLf
            .Body = .Body & "Subject: " & MI.Subject & vbCrLf
            .Body = .Body & vbCrLf
            .Body = .Body & MI.Body
            .Attachments.Add MI, , 1
            .Display
        End With
    Case vbYes
         'If Yes, create task with no due or start date
        Set TI = Application.CreateItem(olTaskItem)
        With TI
            .Subject = MI.Subject
            .Body = "View Original Mail attacched at the bottom"
            .Body = .Body & vbCrLf & vbCrLf
            .Body = .Body & "-----Original Message-----" & vbCrLf
            .Body = .Body & "From: " & MI.Sender & " [mailto:" & MI.SenderEmailAddress & "]" & vbCrLf
            .Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
            .Body = .Body & "To: " & MI.To & vbCrLf
            .Body = .Body & "Cc: " & MI.CC & vbCrLf
            .Body = .Body & "Subject: " & MI.Subject & vbCrLf
            .Body = .Body & vbCrLf
            .Body = .Body & MI.Body
            .Attachments.Add MI, , 1
          
            '.StartDate = Date
            '.DueDate = Date + 1
            '.ReminderTime = .DueDate & " 10:00"
            '.Save
            .Display
          
                      
          
        End With
         'Case vbCancel
         '   Exit Sub
    End Select
End Sub