Redirect Messages
Redirect E-Mail message with VBA
This macro, added to the email toolbar and/or the Explorer toolbar, will forward the active/selected mail item to the recipient of your choice. The original sender of the mail and the newly selected recipient are placed in the "To:" field. Replies are directed to the newly selected recipient (via Options button, 'Send Replies To') and everyone else from the original email is CC'd (so they can ignore). You can also disable 'Reply To All' so the original sender or the new recipient can't send any more irrelevant emails to you.
Update 10/1/08: A site visitor reminded me that the code should check if a valid recipient was entered, and error out if nothing was typed. Below is the slightly rearranged code. –JP
Sub RedirectMail()
'
' This macro forwards the active mail item, or if you are in the explorer window,
' select one email and run this code
'1. The original sender of the mail, and the newly selected recipient are placed
' in the "To:" field
'2. Directs replies to the newly selected recipient
'3. Add everybody else on the CC line (so they can safely ignore, since they
' shouldn't have received it in the first place)
'4. Disables "Reply to All" (optional)
' based on OL2007 code from aaronlerch.com
'
Dim CurrMail As Outlook.MailItem
Dim NewFwd As Outlook.MailItem
Dim sRecipient As Outlook.Recipient
Dim CorrRecip As String
Dim DisableReplyToAll As VbMsgBoxResult
Dim i As Long
On Error Resume Next
Set CurrMail = ActiveInspector.CurrentItem
If CurrMail Is Nothing Then
' we might be in the explorer window
If (ActiveExplorer.Selection.Count = 1) And _
(ActiveExplorer.Selection.Item(1).Class = olMail) Then
Set CurrMail = ActiveExplorer.Selection.Item(1)
End If
End If
On Error GoTo 0
If CurrMail Is Nothing Then
' either a mail msg is not open, or more than one email selected in explorer
' window, or no email selected at all, cannot set ref
MsgBox "I was not able to forward an email. Please run this code ONLY " & _
"under one of the following conditions:" & vbCr & vbCr & _
"-- You are viewing a single email message." & vbCr & _
"-- You are in your Inbox and have exactly one message selected.", _
vbInformation
GoTo ExitProc
End If
' find out who the email should have gone to, and add them to 'To' field
CorrRecip = InputBox("Who should this email have gone to?" & vbCr & vbCr & _
"Enter ONE email address, distribution list, or display name.")
If Len(CorrRecip) = 0 Then Goto ExitProc
Set NewFwd = CurrMail.forward
NewFwd.Display
' delete any "direct replies to" recipients of newly forwarded msg, usually zero
If (NewFwd.ReplyRecipients.Count > 0) Then
For i = 1 To NewFwd.ReplyRecipients.Count
NewFwd.ReplyRecipients.Remove (i)
Next i
End If
DisableReplyToAll = MsgBox("Would you like to disable 'Reply To All'?", _
vbYesNo + vbDefaultButton1)
Select Case DisableReplyToAll
Case vbYes
ActiveInspector.CurrentItem.Actions("Reply to All").Enabled = False
Case Else
End Select
With NewFwd
' add correct recipient as specified to the "direct replies to" option box,
' that way they get any replies if the original sender hits Ctrl-R
.ReplyRecipients.Add (CorrRecip)
' add original sender & correct recipients to TO field
.Recipients.Add(CurrMail.SenderEmailAddress).Type = olTo
.Recipients.Add(CorrRecip).Type = olTo
' add original recipient(s) to CC field
For Each sRecipient In CurrMail.Recipients
Set sRecipient = .Recipients.Add(sRecipient.Name)
With sRecipient
.Type = olCC
.Resolve
End With
Next sRecipient
' If NewFwd.BodyFormat <> olFormatHTML Then
NewFwd.HTMLBody = "<p>Hello " & Left$(CurrMail.SenderName, _
InStr(1, CurrMail.SenderName, " ") - 1) & "," & _
"<p>I think you sent this to the wrong distribution list. </p>" & _
<p>I am redirecting to the appropriate parties and CC’ing original recipients.</p>
<p>Thx all!</p>" & NewFwd.HTMLBody
' Else
' NewFwd.Body = "Hello " & _
Left$(CurrMail.SenderName, InStr(1, CurrMail.SenderName, " ") - 1) & _
"," & vbCr & "I think you sent this to the wrong distribution list." & _
vbCr & "I am redirecting to the appropriate parties and CC’ing original
recipients." & NewFwd.Body
' End If
.Recipients.ResolveAll
.ReplyRecipients.ResolveAll
.Display
'.Send
End With
ExitProc:
Set CurrMail = Nothing
Set NewFwd = Nothing
Set sRecipient = Nothing
End Sub
'
' This macro forwards the active mail item, or if you are in the explorer window,
' select one email and run this code
'1. The original sender of the mail, and the newly selected recipient are placed
' in the "To:" field
'2. Directs replies to the newly selected recipient
'3. Add everybody else on the CC line (so they can safely ignore, since they
' shouldn't have received it in the first place)
'4. Disables "Reply to All" (optional)
' based on OL2007 code from aaronlerch.com
'
Dim CurrMail As Outlook.MailItem
Dim NewFwd As Outlook.MailItem
Dim sRecipient As Outlook.Recipient
Dim CorrRecip As String
Dim DisableReplyToAll As VbMsgBoxResult
Dim i As Long
On Error Resume Next
Set CurrMail = ActiveInspector.CurrentItem
If CurrMail Is Nothing Then
' we might be in the explorer window
If (ActiveExplorer.Selection.Count = 1) And _
(ActiveExplorer.Selection.Item(1).Class = olMail) Then
Set CurrMail = ActiveExplorer.Selection.Item(1)
End If
End If
On Error GoTo 0
If CurrMail Is Nothing Then
' either a mail msg is not open, or more than one email selected in explorer
' window, or no email selected at all, cannot set ref
MsgBox "I was not able to forward an email. Please run this code ONLY " & _
"under one of the following conditions:" & vbCr & vbCr & _
"-- You are viewing a single email message." & vbCr & _
"-- You are in your Inbox and have exactly one message selected.", _
vbInformation
GoTo ExitProc
End If
' find out who the email should have gone to, and add them to 'To' field
CorrRecip = InputBox("Who should this email have gone to?" & vbCr & vbCr & _
"Enter ONE email address, distribution list, or display name.")
If Len(CorrRecip) = 0 Then Goto ExitProc
Set NewFwd = CurrMail.forward
NewFwd.Display
' delete any "direct replies to" recipients of newly forwarded msg, usually zero
If (NewFwd.ReplyRecipients.Count > 0) Then
For i = 1 To NewFwd.ReplyRecipients.Count
NewFwd.ReplyRecipients.Remove (i)
Next i
End If
DisableReplyToAll = MsgBox("Would you like to disable 'Reply To All'?", _
vbYesNo + vbDefaultButton1)
Select Case DisableReplyToAll
Case vbYes
ActiveInspector.CurrentItem.Actions("Reply to All").Enabled = False
Case Else
End Select
With NewFwd
' add correct recipient as specified to the "direct replies to" option box,
' that way they get any replies if the original sender hits Ctrl-R
.ReplyRecipients.Add (CorrRecip)
' add original sender & correct recipients to TO field
.Recipients.Add(CurrMail.SenderEmailAddress).Type = olTo
.Recipients.Add(CorrRecip).Type = olTo
' add original recipient(s) to CC field
For Each sRecipient In CurrMail.Recipients
Set sRecipient = .Recipients.Add(sRecipient.Name)
With sRecipient
.Type = olCC
.Resolve
End With
Next sRecipient
' If NewFwd.BodyFormat <> olFormatHTML Then
NewFwd.HTMLBody = "<p>Hello " & Left$(CurrMail.SenderName, _
InStr(1, CurrMail.SenderName, " ") - 1) & "," & _
"<p>I think you sent this to the wrong distribution list. </p>" & _
<p>I am redirecting to the appropriate parties and CC’ing original recipients.</p>
<p>Thx all!</p>" & NewFwd.HTMLBody
' Else
' NewFwd.Body = "Hello " & _
Left$(CurrMail.SenderName, InStr(1, CurrMail.SenderName, " ") - 1) & _
"," & vbCr & "I think you sent this to the wrong distribution list." & _
vbCr & "I am redirecting to the appropriate parties and CC’ing original
recipients." & NewFwd.Body
' End If
.Recipients.ResolveAll
.ReplyRecipients.ResolveAll
.Display
'.Send
End With
ExitProc:
Set CurrMail = Nothing
Set NewFwd = Nothing
Set sRecipient = Nothing
End Sub
This code is adapted from code found at Aaron Lerch's blog and also some excellent code at Scott Hanselman's blog.
