Outlook Technologies

Outlook Forms

Languages

Samples

More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 02-Sep-2010 22:32

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: beginner Code area: Basic Outlook Printer Friendly Version
Title: Report Spam!
Description: Sends copy of e-mail body and full Internet header to sender's mail host, then deletes original message. This is just a couple hours' of very quick and dirty coding, could certainly be easily improved. (Hint: After I compiled it and tested it, I threw a button on the Message toolbar--not the maon Outlook toolbar--so I can just open a message, click an icon, and it runs!) Might be security issues with some people's installations, ie, allowing macros to run, allowing the code to send an e-mail, etc.
Date: 19-May-2003 05:44
Code level: beginner
Code area: Basic Outlook
Posted by: Brian Battles
Body: 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
All 27comments

	Page [ 1 2 3 Next >> ]
	Bryan 07-Nov-2003 12:10 Sorry, new at this, but I get on a compile error on this: Dim objSession As MAPI.Session Also, this is a bit more complicated that I think I need. All I need to do is forward an email to one specific address, then delete the email. Is something like that available?
	Sue Mosher 07-Nov-2003 18:36 Did you add a reference to the Collaboration Data Objects (CDO) library to your project? That's what you need to be able to use MAPI.* declarations. Forwarding and deleting is much, much simpler than what you have here. Once you have the message you want to forward and delete as an object variable (e.g. objMail), it's just: Set objForward = objMail.Forward objForward.To = "someome@somewhere.com" objForward.Send ' [1] objMail.Delete set objMail = Nothing Set objForward = Nothing [1] Will trigger security prompt -- see http://www.slipstick.com/outlook/esecup.htm#autosec
	Tom 14-May-2004 13:44 (Help) Forwarding spam as attachment. My office is using MDaemon as our email server. It's spam reporter requires that the spam email be forwarded as an attachment. I created an Outlook 2000 macro to create a new mail item, attach the selected mail item to the new mail item, send the new mail item to "spam@somewhere.com" and delete the selected mail item. The only problem I have is that MDaemon sends me back a reply saying: "Incorrect Message Format"... "The message(s) you submitted to the spam or ham learning system were not accepted. You must submit these messages to MDaemon as attachments of type message/rfc822. When using Outlook Express use the 'Forward as attachment' feature." Here is the code I have: '############# Outlook 2000 Spam Reporting Macro ################## ' Select the Mail Item you want to report to spam and run this code Public Sub SendToSpam() Dim objOL As Outlook.Application Dim objSelection As Outlook.Selection Dim objMsg As Object Dim objNewMsg As Object On Error Resume Next ' Instantiate an Outlook Application object Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects Set objSelection = objOL.ActiveExplorer.Selection ' This code sends the selected mail items For Each objMsg In objSelection ' This code only sends mail items If objMsg.Class = olMail Then ' Create a new mail Item Set objNewMsg = Application.CreateItem(olMailItem) ' send the new mail item to the spam reporting email address objNewMsg.To = "spam@somewhere.com" ' add selected mail item as attachment to new mail item objNewMsg.Attachments.Add objMsg ' send the new mail item objNewMsg.Send ' Clear the New Mail Item object Set objNewMsg = Nothing ' Delete the spam mail item objMsg.Delete End If Next ExitSub: Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub '############# End of Outlook 2000 Spam Reporting Macro ########### I have searched for two days to find a way to make this work... any help would be appreciated!
	Tom 14-May-2004 14:35 Addition: I wanted to point out that the new mail item that is created looks just like a new mail item that I create without Automation by clicking the new mail button and then dragging the spam mail onto the new mail item and clicking send. I also tried [automation] saving the spam email item as a file and attaching the file to the new mail item with the following modified code: '############# Outlook 2000 Spam Reporting Macro ################## ' Select the Mail Item you want to report to spam and run this code Public Sub SendToSpam() Dim objOL As Outlook.Application Dim objSelection As Outlook.Selection Dim objMsg As Outlook.MailItem Dim objNewMsg As Outlook.MailItem Dim FSO As FileSystemObject On Error Resume Next ' Instantiate an Outlook Application object Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects Set objSelection = objOL.ActiveExplorer.Selection ' This code sends the selected mail items For Each objMsg In objSelection ' This code only sends mail items If objMsg.Class = olMail Then 'save as temp file objMsg.SaveAs "c:\temp.msg" ' Create a new mail Item Set objNewMsg = Application.CreateItem(olMailItem) ' send the new mail item to the spam reporting email address objNewMsg.To = "spam@somewhere.com" ' add selected mail item as attachment to new mail item objNewMsg.Attachments.Add "c:\temp.msg" ' send the new mail item objNewMsg.Send ' delete the temp file Set FSO = New FileSystemObject FSO.DeleteFile "c:\temp.msg" Set FSO = Nothing ' Clear the New Mail Item object Set objNewMsg = Nothing ' Delete the spam mail item objMsg.Delete End If Next ExitSub: Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub '############# End of Outlook 2000 Spam Reporting Macro ###########
	johnsaxton 15-Jun-2004 13:27 Is there a way to get the internet headers from the mail message without using CDO or other external libraries/tools like Redemption. I would prefer to do this in .NET/C#, but I am perfectly capable of programming much closer to the metal (C/C++) if necessary.
	Sue Mosher 16-Jun-2004 06:09 Yes, John, you could use Extended MAPI. See http://www.outlookcode.com/d/mapi.htm for references .
	johnsaxton 16-Jun-2004 07:27 Thanks!
	Per Setterberg 31-Oct-2004 13:36 Hi, I'm using VB 5 and Outlook 9 (yeah, I know:). It seems I don't have the Fields property (object?) in either of them. How can I reach the pr_transport_message_headers then? Was thinking to keep a spam folder under the inbox to move the messages to, so I don't have to open them one by one. The macro could then purge the spam folder and the button could be placed on the main toolbar. Another idea is to download the www index page from the server obtained through the message-id, look for any email addresses on that page and also send a spam report to those addresses (or at least one), provided they're on the same server. Even better would be to follow any links on the index page and look for email addresses, such as "contact us"-pages. This could be more effective than to use only abuse, postmaster or webmaster addresses. But first I've got to get hold of the message-id!!!-) Any ideas? /Per
	Sue Mosher 01-Nov-2004 08:19 Fields is a property of the CDO Message object (MAPI.Message). Do you have CDO 1.21 installed? It's an optional component for Outlook.
	Per Setterberg 01-Nov-2004 16:39 Hi Sue, Thanks. Yes, I have cdo 1.21 installed. I also followed microsofts advice and registered it with regsvr32, and it seemed ok. But there is sth fishy, I have problems with the mapi.session and mapi.message datatypes in Brian's code as well. Don't know how to get around it... /Per
	Page [ 1 2 3 Next >> ]

name email