无意中看到以下代码。你可以试试。 转自:http://www.codeforexcelandoutlook.com/Outlook.html http://www.outlookcode.com/codedetail.aspx?id=1769(这里也有) 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) '5. 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
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 ' 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.")
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抜ng 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抜ng 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
[此贴子已经被作者于2008-6-4 3:05:14编辑过] |