Solved: Macro to create ToDo from Email

[bendalton]

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:
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

[MOS MASTER]

Hi and Welcome to VBAX! :hi:

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


Insert a new Module and put this in there:
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


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:

[bendalton]

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

Thanks, I appreciate the help.

[MOS MASTER]

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

[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

[MOS MASTER]

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:
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


The other code is OK.

HTH. :whistle:

[Kennyg]

Thanks Mos, works great.

Ken

[MOS MASTER]

Thanks Mos, works great.

Ken

Hi Ken,

Glad I could help! :beerchug:

[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:

[MOS MASTER]

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:

[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

[MOS MASTER]

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:

[francis]

Hi Mos,

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

Pls advise

Cheers,

[Kennyg]

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