Solved: Macro to create ToDo from Email

I found the code I need to make this work, but I'm having difficutly assigning a button to this code AND making it run.. I'm using office 2k3, anyone mind helping me get this working so I can just highlite a message, click the button, and get it all going?

Here is the code I have:
[VBA]Public Sub MakeTaskFromMail(MyMail As Outlook.MailItem)
Dim objTask As Outlook.TaskItem
Set objTask = Application.CreateItem(olTaskItem)
With objTask
.Subject = MyMail.Subject
.DueDate = MyMail.SentOn
.Body = MyMail.Body
End With
If MyMail.Attachments.Count > 0 Then
Call CopyAttachments(MyMail, objTask)
End If
objTask.Save
Set objTask = Nothing
End Sub

Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing
End Sub
[/VBA]

Hi and Welcome to VBAX! :hi:

Put this code in classModule: ThisOutlookSession:[VBA]
Option Explicit 'Only one in every code module on top!
Private Sub Application_Startup()
AddMyButton
End Sub
[/VBA]

Insert a new Module and put this in there:[VBA]
Option Explicit 'Only one in every code module on top!

Sub AddMyButton()
Dim oBar As Office.CommandBar
Dim oButton As Office.CommandBarButton
Set oBar = Application.ActiveExplorer.CommandBars("Standard")
Set oButton = oBar.Controls.Add(Type:=msoControlButton, Before:=7, Temporary:=True)
With oButton
.Caption = "Create Task"
.FaceId = 1086
.Style = msoButtonIconAndCaption
.OnAction = "MakeTaskFromMail"
End With
Set oButton = Nothing
Set oBar = Nothing
End Sub
Private Sub MakeTaskFromMail()
Dim MyMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem
For Each MyMail In Application.ActiveExplorer.Selection
Set objTask = Application.CreateItem(olTaskItem)

With objTask
.Subject = MyMail.Subject
.DueDate = MyMail.SentOn
.Body = MyMail.Body
End With

If MyMail.Attachments.Count > 0 Then
Call CopyAttachments(MyMail, objTask)
End If

objTask.Save
Set objTask = Nothing
Next

End Sub

Private Sub CopyAttachments(objSourceItem, objTargetItem)
Dim fso As Object, fldTemp As Object
Dim strPath As String, strFile As String
Dim objAtt As Outlook.Attachment
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"

For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing
End Sub
[/VBA]

Save your project and close Outlook
Restart it and you will see the new button.

Select a message(s) and click the button to execute.

Enjoy! :whistle:

BEAUTIFUL!!!!! (Makes my work life a HAPPY)

Thanks, I appreciate the help.

Hi, :D
You're Welcome! :beerchug:

I just found this code, and it works great, i have been trying to do the same thing and had given up until i found this forum. What modifications would you have to do to the code to attach the actual email to the new task, rather than just the attachments?

Ken

Quote:

---

Originally Posted by Kennyg

I just found this code, and it works great, i have been trying to do the same thing and had given up until i found this forum. What modifications would you have to do to the code to attach the actual email to the new task, rather than just the attachments?

Ken

---

Hi Ken, :hi:

I've been away for a while so a late reply on my part.

This Mod wil do what you want:[vba]
Private Sub MakeTaskFromMail()
Dim myMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem
For Each myMail In Application.ActiveExplorer.Selection
Set objTask = Application.CreateItem(olTaskItem)

With objTask
.Subject = myMail.Subject
.DueDate = myMail.SentOn
' .Body = myMail.Body
.Attachments.Add myMail 'this is all that you need to add ;-)
End With

If myMail.Attachments.Count > 0 Then
Call CopyAttachments(myMail, objTask)
End If

objTask.Save
Set objTask = Nothing
Next

End Sub
[/vba]

The other code is OK.

HTH. :whistle:

Thanks Mos, works great.

Ken

Quote:

---

Originally Posted by Kennyg

Thanks Mos, works great.

Ken

---

Hi Ken,

Glad I could help! :beerchug:

OK Mos, Here's another one for you - hopefully simpler for you than it is proving for me. The code above puts a button on the main Outlook toolbar, but I can't work out the change I need to make to put one on the Standard toolbar that you see when you have the message open?

Ken:banghead:

Quote:

---

Originally Posted by Kennyg

OK Mos, Here's another one for you - hopefully simpler for you than it is proving for me. The code above puts a button on the main Outlook toolbar, but I can't work out the change I need to make to put one on the Standard toolbar that you see when you have the message open?

Ken:banghead:

---

Hi Ken, :D

You can use this kb-article I wrote to do that:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=502

HTH. :whistle:

Thanks Mos, it took a gumby like me a bit of fiddling, but I have worked it out now, and got it doing what I want.
Thanks for all of your help


Ken
:thumb

Quote:

---

Originally Posted by Kennyg

Thanks Mos, it took a gumby like me a bit of fiddling, but I have worked it out now, and got it doing what I want.
Thanks for all of your help


Ken
:thumb

---

Glad I could help Ken! :beerchug:

Hi Mos,

I use the KB given by the above link and its didn't work.

Pls advise

Cheers,

Is there anything that needs to be changed in this code to make this code run in Outlook 2007?