Option Explicit
Sub AtWaitingForTasksFromEmail()
' Comments :
' Parameters: -
' Modified : 12/06/2004 - B.Davidson
'
' --------------------------------------------------
Dim objTask As Outlook.TaskItem
Dim objApp As Outlook.Application
Dim objCurrentItem As Object 'currently selected item in Outlook
Dim objRecips As SafeRecipients 'All recipients on message
Dim objRecip As SafeRecipient 'Current recipient
Dim objWFMail 'for Redemption mail item
Dim objForward 'for Redemption mail item for getting mail body with headers
Set objApp = Outlook.CreateObject("Outlook.Application")
Set objCurrentItem = GetCurrentItem() 'get currently selected item
Set objWFMail = CreateObject("Redemption.SafeMailItem") 'use Redemption to bypass the security prompts
objWFMail.Item = objCurrentItem 'use Redemption to bypass the security prompts
If objWFMail.Class = olMail Then 'only run if the current item is a mail message
Set objRecips = objWFMail.Recipients 'get all the recipients on the message (To, CC)
For Each objRecip In objRecips 'check all the recipients
If objRecip.Type = olTo Then 'if the current recipient is on the To line, create a @WF task
Set objTask = objApp.CreateItem(olTaskItem) 'create a blank task
'Set the subject per the DA white paper format (Name, Date, Subject
objTask.Subject = objRecip.Name & " - " & Format(objWFMail.SentOn, "mm/dd/yyyy") & " - " & objWFMail.Subject
'Create a forwarded copy of the message to preserve the headers in the @WF task
Set objForward = CreateObject("Redemption.SafeMailItem")
objForward.Item = objCurrentItem.Forward
objForward.Save 'save the draft forward message so redemption can see it
objTask.Body = objForward.Body '
objForward.Delete 'delete the draft message (no longer needed)
objTask.Categories = "@Waiting For" 'Change to whatever category you like
objTask.Save 'save your work!
End If 'objRecip.Type = olTo
Next 'go process the next recipient
Else:
MsgBox "Oops!!! This macro only works with Mail Items."
Exit Sub
End If
'Variable cleanup
Set objTask = Nothing
Set objForward = Nothing
Set objRecip = Nothing
Set objRecips = Nothing
Set objWFMail = Nothing
Set objCurrentItem = Nothing
Set objApp = Nothing
End Sub
Function GetCurrentItem() As Object
' Comments :
' Parameters: -
' Returns : Object -
' Modified :
'
' --------------------------------------------------
Dim objApp As Application
Dim objSel As Selection
Dim objCurrentItem As Object
Set objApp = CreateObject("Outlook.Application")
Select Case objApp.ActiveWindow.Class
Case olExplorer
Set objSel = objApp.ActiveExplorer.Selection
If objSel.Count > 0 Then
Set objCurrentItem = objSel.Item(1)
End If
Case olInspector
Set objCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
End Select
Set GetCurrentItem = objCurrentItem
Set objCurrentItem = Nothing
Set objSel = Nothing
Set objApp = Nothing
End Function