Creating tasks and appointments based on email messages

Quite often in our business life we need to complete tasks that have been described in the emails received to our mailbox.  

If the task is short, we can complete it right away and then send a message to the sender.  However, if the task requires some time and effort, then it may be difficult to find the original message among hundreds of other emails. You can drag-and-drop the message and create a task but it will not have email attached, there will be no additional settings (due date or reminder) and the task will only apply to the original message. 

The procedure below will create a task or appointment based on selected message or messages (you can select multiple messages in the inbox) with a set of due date and reminder.  

Option Explicit  Sub Tasks()     Call Create_Appointment_or_Task(False, 3) End Sub  Sub Create_Appointment_or_Task(Calendar_no_Task As Boolean, TimeInterval&)     Dim objItem As MailItem     Dim objJob As Object     Dim x&, Entry As Collection
    Const AttPath$ = "C:\"
    
    On Error GoTo error
    Set Entry = New Collection
    If objItem Is Nothing Then
        With ActiveExplorer.Selection
            For x = 1 To .Count
                If .Item(x).Class <> 43 Then GoTo skip
                DoEvents
                Set objItem = .Item(x)
                objItem.SaveAs AttPath & objItem.EntryID
                Entry.Add objItem.EntryID
                skip:
                Next x
            End With
        End If
       
        If Calendar_no_Task = True Then
            Set objJob = CreateItem(olAppointmentItem)
        Else
            Set objJob = CreateItem(olTaskItem)
        End If
       
        With objJob
            If Calendar_no_Task = True Then
                .Start = Now + TimeInterval
                .End = Now + TimeInterval
            Else
                .Status = olTaskInProgress
                .DueDate = Now + TimeInterval
                .StartDate = Now + TimeInterval
                .ReminderTime = Now + TimeInterval
            End If
            .Subject = "Remind about: " & objItem.Subject
            .Categories = "VBATools.pl"
            .Importance = objItem.Importance
            .ReminderSet = True
            .Body = "Created " & Now & " based on the email:" & vbCr
            For x = 1 To Entry.Count
                DoEvents
                objJob.Attachments.Add AttPath & Entry.Item(x), olEmbeddeditem
                Kill (AttPath & Entry.Item(x))
            Next
            .Display 'or .Save if we don't want to see an object
        End With
        Exit Sub
        error:
        MsgBox "Execution error:" & Err.Number & vbCr & _
        Err.Description, vbExclamation, "VBATools.pl"
    End Sub
 

If you want to extend the functionality, you can connect this procedure to a form with a date, automatic due date and save option without displaying the object in Outlook. 

You can also put the Create_Appointment_or_Task procedure under a button on the Outlook toolbar. You can read how to do it in the article Installation and running macros.