VBA OutLook: Criando tarefas a partir de um e-mail.

Copie o código abaixo e cole no editor VBA do Outlook (Acesse o editor pressionando ALT+F11 no Outlook). Então crie um botão no "Quick Access Toolbar" para mensagens de e-mail que acessem a função "ContruaTarefasDOeMail()".


Sub ContruaTarefasDOeMail()
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim objTask As Outlook.TaskItem

Set objMail = Outlook.Application.ActiveInspector.CurrentItem

strID = objMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
Set objFolder = olNS.PickFolder
Set objTask = objFolder.Items.Add(olTaskItem)
objRecipients = InputBox("Queira digitar um usuário adicional para ser atualizado, separado por ponto e vírgula:", ".: A&A - Lista de atualização")
With objTask
.Subject = olMail.Subject
.Body = olMail.Body
.StatusUpdateRecipients = olMail.SenderEmailAddress & "; " & objRecipients
.StatusOnCompletionRecipients = olMail.SenderEmailAddress & "; " & objRecipients
End With

Call TarefaAnexar(olMail, objTask)

objTask.Display

Set objTask = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub

Sub TarefaAnexar(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2)

Let strPath = fldTemp.Path & "\"

For Each objAtt In objSourceItem.Attachments
Let 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