Option Explicit
' this module will look at the currently open Outlook e-mail message, and then
' it looks up the apparent and real "from" addresses from the Internet headers,
' then generates a new message consisiting of the complete Internet header and the
' body of the original message, and sends it to the "abuse" addresses at the domains
' involved, ie, "abuse@hotmail.com" or "abuse@jackpot.com"
' It will even attempt to parse the header data to create the proper address for
' messages appearing to come from domains like "mail.server.jackpot.com" etc,
' for those, it creates an address like "abuse@jackpot.com" and ignores the additional
' fields before the "whatever.com" part of the domain
' Built for use as a "macro" (VBA module) inside Microsoft Outlook 2003;
' I added it to my Message toolbar you see when viewing an e-mail message
' (NOT the main Outlook application toolbar)
'
' requires References to
' Microsoft CDO 1.21 library (CDO.DLL)
' Microsoft Outlook 11 Object Library
' Microsoft Office 11 Object Library
'
' Written by Brian Battles WS1O (brian@brianbattles.com)
'
' I tested it with Outlook 2003 Beta under Windows XP Pro
'
' No guarantees, warrantees or anything, you're on your own with this!
Public Sub SendSpamComplaintToMailHost()
' take current message, grab body text and Internet headers,
' and send a copy to the "abuse" address of their mailhost
'
' Modified: 5/17/2003 By BB
Dim strAddress As String
Dim strMailHost As String
Dim strSendTo As String
Dim strHeaders As String
Dim strSender As String
Dim strBody As String
Dim iPos As Integer
Dim ctlCBarCombo As CommandBarControl
Dim cbrNewToolbar As CommandBar
On Error GoTo Err_SendSpamComplaintToMailHost
Set cbrNewToolbar = Application.ActiveExplorer.CommandBars.Add(Name:="Status", Position:=msoBarTop, Temporary:=True)
Set ctlCBarCombo = cbrNewToolbar.Controls.Add(Type:=msoControlEdit)
With ctlCBarCombo
.Caption = "Spam Report Sent "
.Text = "Original Message Deleted"
.Style = msoComboLabel
.TooltipText = "Spam Report Sent, Original Message Deleted"
End With
cbrNewToolbar.Visible = True
DoEvents
strAddress = FromAddress
iPos = InStr(strAddress, "@")
strAddress = Right(strAddress, Len(strAddress) - iPos)
iPos = InStr(strAddress, ".com")
strSender = CreateAbuseAddress
strMailHost = Right(strAddress, Len(strAddress) - iPos)
strSendTo = strSender & ";" & "abuse@" & strAddress & ";" & "postmaster@" & strAddress & ";" & "administrator@" & strAddress
' get message's Internet headers
strHeaders = InternetHeaders
' get messages's body
strBody = GetMessageBody
strBody = strHeaders & vbCrLf & vbCrLf & vbCrLf & vbCrLf & strBody
' send new message containing headers & body to mail host's "abuse" address
SendNewMessage strSendTo, strBody
' delete original message
DeleteMessage
' close original message
CloseMessage
'MsgBox "Copy of message sent to sender's mail hosts, and original message deleted" & vbCrLf & vbCrLf & "Look in your 'Sent Mail' folder if you want to see the report you e-mailed", vbInformation, " Spam Report Sent"
cbrNewToolbar.Delete
Exit_SendSpamComplaintToMailHost:
On Error GoTo 0
Exit Sub
Err_SendSpamComplaintToMailHost:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "SendSpamComplaintToMailHost"
Resume Exit_SendSpamComplaintToMailHost
End Select
End Sub
Private Function FromAddress() As String
' Modified: 5/17/2003 By BB
' Get the sender's e-mail address
On Error GoTo Err_FromAddress
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objSession As MAPI.Session
Dim objMsg As MAPI.Message
Dim objSender As MAPI.AddressEntry
Dim strAddress As String
Dim strName As String
Dim strEntryID As String
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOutlook = CreateObject("Outlook.Application")
'The ActiveInspector window is the currently active window
'That is displaying individual Outlook items. Outlook folders
'are displayed in Explorer windows.
Set objItem = objOutlook.ActiveInspector.CurrentItem
'SenderName is the friendly name
strName = objItem.SenderName
'We need the EntryID of the item to locate it with CDO
strEntryID = objItem.EntryID
'Establish a CDO (MAPI) Session object and logon to it
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False
'Locate the current message with the EntryID using CDO
Set objMsg = objSession.GetMessage(strEntryID)
'Get the sender
Set objSender = objMsg.Sender
'Get the actual e-mail address
strAddress = objSender.Address
FromAddress = strAddress
'Close MAPI (CDO) Session
objSession.Logoff
Exit_FromAddress:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objSession Is Nothing) Then
Set objSession = Nothing
End If
If Not (objMsg Is Nothing) Then
Set objMsg = Nothing
End If
If Not (objSender Is Nothing) Then
Set objSender = Nothing
End If
On Error GoTo 0
Exit Function
Err_FromAddress:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "FromAddress"
Resume Exit_FromAddress
End Select
End Function
Private Function InternetHeaders() As String
' Modified: 5/17/2003 By BB
' Capture the Internet headers from the current message
'
' The Internet headers are only present in e-mails received from POP3 e-mails.
' They're not present in e-mails sent over Microsoft Exchange server.
' This function returns the Internet headers as a string value
On Error GoTo Err_InternetHeaders
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim strID As String
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOutlook = CreateObject("Outlook.Application")
'Find the current email item and get its EntryID
Set objItem = objOutlook.ActiveInspector.CurrentItem
strID = objItem.EntryID
'Then set up a CDO Session using a piggy-back login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
'Now get the item as a CDO Message
Set objMessage = objCDO.GetMessage(strID)
'Now get the headers from the message
Set objFields = objMessage.Fields
InternetHeaders = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
'Now that the headers are captured in a string you can do whatever you want with them
objCDO.Logoff
Exit_InternetHeaders:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
If Not (objMessage Is Nothing) Then
Set objMessage = Nothing
End If
If Not (objFields Is Nothing) Then
Set objFields = Nothing
End If
On Error GoTo 0
Exit Function
Err_InternetHeaders:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "InternetHeaders"
Resume Exit_InternetHeaders
End Select
End Function
Private Function GetMessageBody() As String
' Modified: 5/17/2003 By BB
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim strID As String
On Error GoTo Err_GetMessageBody
' Instantiate an Outlook Application object
Set objOutlook = CreateObject("Outlook.Application")
'Find the current email item and get its EntryID
Set objItem = objOutlook.ActiveInspector.CurrentItem
strID = objItem.EntryID
'Then set up a CDO Session using a piggyback login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
'Now get the item as a CDO Message
Set objMessage = objCDO.GetMessage(strID)
'Now get the headers from the message
Set objFields = objMessage.Fields
GetMessageBody = objFields.Item(CdoPR_BODY).Value
'Now that the headers are captured in a string you can do whatever you want with them
objCDO.Logoff
Exit_GetMessageBody:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
If Not (objMessage Is Nothing) Then
Set objMessage = Nothing
End If
If Not (objFields Is Nothing) Then
Set objFields = Nothing
End If
On Error GoTo 0
Exit Function
Err_GetMessageBody:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "GetMessageBody"
Resume Exit_GetMessageBody
End Select
End Function
Private Sub SendNewMessage(strToAddress As String, strMessageBody As String)
' Modified: 5/17/2003 By BB
On Error GoTo Err_SendNewMessage
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
' Instantiate an Outlook Application object
Set objOutlook = CreateObject("Outlook.Application")
'Then set up a CDO Session using a piggyback login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
' create a new e-mail message
Set objItem = objOutlook.CreateItem(olMailItem)
objItem.Body = strMessageBody
objItem.To = strToAddress
objItem.Subject = "Fraudulent E-Mail Report"
objItem.Send
' Now that the message has been sent, we can finish the session
objCDO.Logoff
Exit_SendNewMessage:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
On Error GoTo 0
Exit Sub
Err_SendNewMessage:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "SendNewMessage"
Resume Exit_SendNewMessage
End Select
End Sub
Private Function ShowSenderHeaders() As String
' Modified: 5/17/2003 By BB
' Capture the REAL sender from the Internet headers in the current message
'
' The Internet headers are only present in e-mails received from POP3 e-mails.
' They're not present in e-mails sent over Microsoft Exchange server.
' This function returns the senders as a string value
On Error GoTo Err_ShowSenderHeaders
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim strID As String
Dim strHeader As String
Dim strAdd As String
Dim lBegPos As Long
Dim lEndPos As Long
Dim lParen As Long
Dim strArr() As String
Dim strNew As String
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOutlook = CreateObject("Outlook.Application")
'Find the current email item and get its EntryID
Set objItem = objOutlook.ActiveInspector.CurrentItem
strID = objItem.EntryID
'Then set up a CDO Session using a piggy-back login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
'Now get the item as a CDO Message
Set objMessage = objCDO.GetMessage(strID)
'Now get the headers from the message
Set objFields = objMessage.Fields
strHeader = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
strArr = Split(strHeader, vbCrLf)
For lBegPos = LBound(strArr) To UBound(strArr)
If Left(strArr(lBegPos), 14) = "Received: from" Then
lEndPos = InStr(strArr(lBegPos), "from")
strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 4))
lParen = InStr(strNew, "(")
If strAdd = "" Then
strAdd = Left$(strNew, lParen - 2)
ElseIf strAdd = Left$(strNew, lParen - 2) Then
' if it's the same don't add it again
Else
strAdd = strAdd & ";" & Left$(strNew, lParen - 2)
End If
ElseIf Left(strArr(lBegPos), 12) = "Received: by" Then
lEndPos = InStr(strArr(lBegPos), "by")
strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 2))
lParen = InStr(strNew, "(")
If strAdd = "" Then
strAdd = Left$(strNew, lParen - 2)
ElseIf strAdd = Left$(strNew, lParen - 2) Then
' if it's the same don't add it again
Else
strAdd = strAdd & ";" & Left$(strNew, lParen - 2)
End If
End If
Next
ShowSenderHeaders = strAdd
'Now that the headers are captured in a string you can do whatever you want with them
objCDO.Logoff
Exit_ShowSenderHeaders:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
If Not (objMessage Is Nothing) Then
Set objMessage = Nothing
End If
If Not (objFields Is Nothing) Then
Set objFields = Nothing
End If
On Error GoTo 0
Exit Function
Err_ShowSenderHeaders:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "ShowSenderHeaders"
Resume Exit_ShowSenderHeaders
End Select
End Function
Private Function CreateAbuseAddress() As String
' Modified: 5/17/2003 By BB
' Capture the REAL sender from the Internet headers in the current message
' and create an address like "abuse@hotmail.com" from it
'
' The Internet headers are only present in e-mails received from POP3 e-mails.
' They're not present in e-mails sent over Microsoft Exchange server.
' This function returns the senders as a string value
On Error GoTo Err_CreateAbuseAddress
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim strID As String
Dim strHeader As String
Dim strAdd As String
Dim lBegPos As Long
Dim lEndPos As Long
Dim lParen As Long
Dim strArr() As String
Dim strNew As String
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOutlook = CreateObject("Outlook.Application")
'Find the current email item and get its EntryID
Set objItem = objOutlook.ActiveInspector.CurrentItem
strID = objItem.EntryID
'Then set up a CDO Session using a piggy-back login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
'Now get the item as a CDO Message
Set objMessage = objCDO.GetMessage(strID)
'Now get the headers from the message
Set objFields = objMessage.Fields
strHeader = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
strArr = Split(strHeader, vbCrLf)
For lBegPos = LBound(strArr) To UBound(strArr)
If Left(strArr(lBegPos), 14) = "Received: from" Then
lEndPos = InStr(strArr(lBegPos), "from")
strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 4))
lParen = InStr(strNew, "(")
If strAdd = "" Then
strAdd = "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
ElseIf strAdd = Left$(strNew, lParen - 2) Then
' if it's the same don't add it again
Else
strAdd = strAdd & ";" & "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
End If
ElseIf Left(strArr(lBegPos), 12) = "Received: by" Then
lEndPos = InStr(strArr(lBegPos), "by")
strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 2))
lParen = InStr(strNew, "(")
If strAdd = "" Then
strAdd = "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
ElseIf strAdd = Left$(strNew, lParen - 2) Then
' if it's the same don't add it again
Else
strAdd = strAdd & ";" & "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
End If
End If
Next
CreateAbuseAddress = strAdd
'Now that the headers are captured in a string you can do whatever you want with them
objCDO.Logoff
Exit_CreateAbuseAddress:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
If Not (objMessage Is Nothing) Then
Set objMessage = Nothing
End If
If Not (objFields Is Nothing) Then
Set objFields = Nothing
End If
On Error GoTo 0
Exit Function
Err_CreateAbuseAddress:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CreateAbuseAddress"
Resume Exit_CreateAbuseAddress
End Select
End Function
Private Function CleanDomainName(strAddressString As String) As String
'Modified: 5/17/2003 By BB
'
' remove multiple periods (".") from a domain name
' all we want are the last 2 sections (ie, from "mail.server.whatever.com" we want "whatever" and "com")
Dim strArray() As String
Dim strDomn As String
Dim L As Long
On Error GoTo Err_CleanDomainName
If InStr(strAddressString, ".") = 0 Then
strDomn = strAddressString & ".com"
Else
strArray = Split(strAddressString, ".")
L = UBound(strArray)
strDomn = strDomn & strArray(L - 1) & "." & strArray(L)
End If
CleanDomainName = strDomn
Exit_CleanDomainName:
On Error GoTo 0
Exit Function
Err_CleanDomainName:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CleanDomainName"
Resume Exit_CleanDomainName
End Select
End Function
Private Sub DeleteMessage()
' Modified: 5/17/2003 By BB
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
Dim objCDO As MAPI.Session
Dim objMessage As MAPI.Message
Dim strID As String
On Error GoTo Err_DeleteMessage
' Instantiate an Outlook Application object
Set objOutlook = CreateObject("Outlook.Application")
'Find the current email item and get its EntryID
Set objItem = objOutlook.ActiveInspector.CurrentItem
strID = objItem.EntryID
'Then set up a CDO Session using a piggyback login
Set objCDO = CreateObject("MAPI.Session")
objCDO.Logon "", "", False, False
'Now get the item as a CDO Message
Set objMessage = objCDO.GetMessage(strID)
objMessage.Delete
' message is deleted, quit session
objCDO.Logoff
Exit_DeleteMessage:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
If Not (objCDO Is Nothing) Then
Set objCDO = Nothing
End If
If Not (objMessage Is Nothing) Then
Set objMessage = Nothing
End If
On Error GoTo 0
Exit Sub
Err_DeleteMessage:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "DeleteMessage"
Resume Exit_DeleteMessage
End Select
End Sub
Private Sub CloseMessage()
' Modified: 5/17/2003 By BB
Dim objOutlook As Outlook.Application
Dim objItem As Outlook.MailItem
On Error GoTo Err_CloseMessage
' Instantiate an Outlook Application object
Set objOutlook = CreateObject("Outlook.Application")
'Find the current e-mail item
Set objItem = objOutlook.ActiveInspector.CurrentItem
objItem.Close olDiscard
Exit_CloseMessage:
On Error Resume Next
If Not (objOutlook Is Nothing) Then
Set objOutlook = Nothing
End If
If Not (objItem Is Nothing) Then
Set objItem = Nothing
End If
On Error GoTo 0
Exit Sub
Err_CloseMessage:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CloseMessage"
Resume Exit_CloseMessage
End Select
End Sub
