You are currently reviewing an older revision of this page.
Go to current version

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
                Set objItem = .Item(x)
                objItem.SaveAs AttPath & objItem.EntryID
                Entry.Add objItem.EntryID
                Next x
            End With
        End If
        If Calendar_no_Task = True Then
            Set objJob = CreateItem(olAppointmentItem)
            Set objJob = CreateItem(olTaskItem)
        End If
        With objJob
            If Calendar_no_Task = True Then
                .Start = Now + TimeInterval
                .End = Now + TimeInterval
                .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
                objJob.Attachments.Add AttPath & Entry.Item(x), olEmbeddeditem
                Kill (AttPath & Entry.Item(x))
            .Display 'or .Save if we don't want to see an object
        End With
        Exit Sub
        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.

If you are not experienced in macro installation in Microsoft Outlook, please refer to the article Installation and running macros

 (c) Shon Oskar 
© All rights reserved. No part or whole of this article may not be reproduced or published without prior permission.
Oryginal article publicate at this page
Revert to this revision