Solved: Create task or calendaritem based on open e-mail

[dragon]

Dear All,

I am trying to amend Charlize's KB entry http://www.vbaexpress.com/kb/getarticle.php?kb_id=981 to include attachments being saved in the task/calendar item that is created, but can't seem to do it.

I tried adding this line in the With AI and With TI sections:

.Attachments = MI.Attachments

but that doesn't work.

Can someone help please?

Thanks

[Charlize]

A first draft will do the trick. This coding can be refined because you can write a function to deal with the attachements (because I used the exact coding two times - one time for the calendar and another for the task).[vba]Public Sub AddCalendarEntry()
Const mailItem_c As String = "MailItem"
'*** Added for saving the temp attachment that you want to
'*** add to the calendaritem / taskitem
Const mypath_c As String = "C:\Data\Attachment_Mail\"
'***
Dim OE As Outlook.Explorer
Dim MI As Outlook.MailItem
Dim AI As Outlook.AppointmentItem
Dim TI As Outlook.TaskItem
'*** ADDED THIS FOR THE ATTACHMENTS
Dim myloop As Long
Dim myfile As String
'***
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)
'*** added section for dealing with attachments
If MI.Attachments.Count > 0 Then
For myloop = 1 To MI.Attachments.Count
MI.Attachments.Item(myloop).SaveAsFile mypath_c & myloop & "-" & _
MI.Attachments.Item(myloop).Filename
Next myloop
'*** loop through directory to add saved attachments
myfile = Dir(mypath_c & "*.*")
Do While myfile <> vbNullString
AI.Attachments.Add mypath_c & myfile
myfile = Dir
Loop
'*** loop again through directory to delete the attachments
myfile = Dir(mypath_c & "*.*")
Do While myfile <> vbNullString
Kill mypath_c & myfile
myfile = Dir
Loop
End If
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)
'*** added section for dealing with attachments
If MI.Attachments.Count > 0 Then
For myloop = 1 To MI.Attachments.Count
MI.Attachments.Item(myloop).SaveAsFile mypath_c & myloop & "-" & _
MI.Attachments.Item(myloop).Filename
Next myloop
'*** loop through directory to add saved attachments
myfile = Dir(mypath_c & "*.*")
Do While myfile <> vbNullString
TI.Attachments.Add mypath_c & myfile
myfile = Dir
Loop
'*** loop again through directory to delete the attachments
myfile = Dir(mypath_c & "*.*")
Do While myfile <> vbNullString
Kill mypath_c & myfile
myfile = Dir
Loop
End If
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[/vba]Charlize

[dragon]

Thats brilliant Charlize.

Works perfectly. Thanks very much.