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