Outlook Report Email to Abuse@Domain & Move to Inbox/Abuse folder

So sick of spammers - here is a quick script to report back to Abuse@ their domain. The top 3 SUB routines can be fire VIA Alt+F8, rules, or Ad Macro to Toolbar 

Attribute VB_Name = "AbuseForardTo" Option Explicit Option Compare Text Const vbqt = """" ''---------------------------------------------------------------------------- ''Email abuse and move original and send Public Sub ReportAbuse_NoPrompt_Send(): ReportAbuse 1, True, False: End Sub ''---------------------------------------------------------------------------- ''Email abuse and move original and send, but set a delay Public Sub ReportAbuse_NoPrompt_Send_Delay(): ReportAbuse 1, True, False, True: End Sub ''---------------------------------------------------------------------------- ''Start an abuse email Public Sub ReportAbuse_NoSend(): ReportAbuse 0, False, False: End Sub ''---------------------------------------------------------------------------- ''PromptDeleteMove = < 0 (delete no promot), > 0 (Move to ABUSE), =0 Prompt (Default) ''Send by default no prompt ''AddSCAMTag to prompt to modify subject line with =(SCAM) or = (SPAM) ''DelayDeliver false by default - set delivery time to the next 5Pm time or 1 hour from Nowif witin and hour of 5pm. ''---------------------------------------------------------------------------- Public Sub ReportAbuse(Optional PromptDeleteMove As Integer = 0, Optional Send As Boolean = True, Optional AddSCAMTag As Boolean = False, Optional DelayDeliver = False) Dim objOriginalMail As Outlook.MailItem '' Original mail Dim objNewMail As Outlook.MailItem '' Email to send Dim strHeaders As String '' Headers Dim strSeparator As String '' Separator between headers and mail body Dim strEmail As String '' Address in case they use reply-to Dim strDomain As String '' Domain to reply to for abuse Dim intAtSymbol As Integer '' Location of @ separator Dim objNamespace As Outlook.NameSpace ''For foldercreation and moving messages Dim objInbox As Outlook.MAPIFolder ''Inbox reference folder Dim objAbuseFolder As Outlook.MAPIFolder ''Destinaton abuse folder Dim DeliverTime As Date ''If delay delivery is employed Set objNamespace = Application.GetNamespace("MAPI") Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox) On Error Resume Next '' Ignore errors which might occur if folder already exists Set objAbuseFolder = objInbox.Folders("Abuse") If objAbuseFolder Is Nothing Then ' If the folder does not exist, create it Set objAbuseFolder = objInbox.Folders.Add("Abuse") End If On Error GoTo 0 '' Turn back on error reporting

If TypeName(Application.ActiveWindow) = "Inspector" Then ''Is current selection a mail item If TypeOf Application.ActiveInspector.CurrentItem Is MailItem Then Set objOriginalMail = Application.ActiveInspector.CurrentItem End If Else If TypeOf Application.ActiveExplorer.Selection.Item(1) Is MailItem Then Set objOriginalMail = Application.ActiveExplorer.Selection.Item(1) End If End If If objOriginalMail Is Nothing Then ''Exit if not mail or if nothing is selected MsgBox "No email is selected or the selected item is not an email." Exit Sub End If ' Extract headers strHeaders = objOriginalMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E") ' Define a separator strSeparator = "--------------------------------------------------------------------" & vbCrLf ' Create a new mail item Set objNewMail = Application.CreateItem(olMailItem) ' Set the new mail's body with headers, separator, and original body objNewMail.Body = Trim(strSeparator & "Headers:" & vbCrLf & strSeparator & strHeaders & vbCrLf & strSeparator & "Body of original message:" & vbCrLf & strSeparator & objOriginalMail.Body) ' Set the subject of the new mail as the same as the original- Usually we skip this. If AddSCAMTag Then Select Case MsgBox("Is it a scam?" & vbCr & "YES for SCAM," & vbCr & "NO for just Spam.", vbYesNoCancel + vbQuestion, "Scam or Spam") Case vbYes objNewMail.Subject = "==(SCAM)" Case vbNo objNewMail.Subject = "==(SPAM)" Case Else Set objNewMail = Nothing Exit Sub End Select End If ''Set subject of new mail objNewMail.Subject = Trim(objOriginalMail.Subject) & Trim(objNewMail.Subject) ''Extract domain from sender's email address for the "To" field If objOriginalMail.ReplyRecipients.Count > 0 Then strEmail = objOriginalMail.ReplyRecipients.Item(1).Address Else strEmail = objOriginalMail.SenderEmailAddress End If ''Split domain from email intAtSymbol = InStr(strEmail, "@") ''Break at "@" If intAtSymbol > 0 Then strDomain = Mid(strEmail, intAtSymbol + 1) objNewMail.To = "Abuse@" & strDomain ''Set Newmail TO address End If ''Save and move the new mail to the 'Abuse' folder objNewMail.Save Set objNewMail = objNewMail.Move(objAbuseFolder) If DelayDeliver Then If Date + Time > Date + 17 / 24 Then ''set delat to deliver in case we accidentally run somethign that shouldn't be run DeliverTime = Date + 1 + 17 / 24 ''Tomorrow at 5pm ElseIf Abs(Date + Time - Date + 17 / 24) < 1 / 24 Then ''within 1 hour of 5pm DeliverTime = Date + Time() + 1 / 24 ''an hour form now Else DeliverTime = Date + 17 / 24 ''5pm End If ''Set delay deliver time objNewMail.DeferredDeliveryTime = DeliverTime End If Select Case PromptDeleteMove Case Is < 0 ''<0 just delete objOriginalMail.Delete Case Is > 0 ''>0 Just move to abuse objOriginalMail.Move objAbuseFolder Case Else ''=0 (Default) Prompt if they want to delete the original email If MsgBox("Do you want to delete the original email?", vbYesNo + vbQuestion, "Delete Original?") = vbYes Then objOriginalMail.Delete ElseIf MsgBox("Do you want to MOVE the original email to Inbox/Abuse?", vbYesNo + vbQuestion, "Delete Original?") = vbYes Then On Error Resume Next ''in case themove fails- testingin Abuse folder objOriginalMail.Move objAbuseFolder On Error GoTo 0 End If End Select If Send Then ''If send then send it objNewMail.Send Else objNewMail.Display ''Otherwise show for user to modify End If End Sub