ol-spam-rpt-vbs

2007.05.11 08:38:27 Update: I no longer recommend or use SpamCOP. Thier MailHosts configuration has become more and more conviluted and confusing, the "user to user" help forum is sometimes quite rude and thier developers are uninterested in improving the user experience. For example, when registering a mailhost, there is an ID number in the header that must match the ID in the body of the email they send. Some MTA (including ASSP) pad header lines with spaces (which, as far as I can see, does not violate any RFQ), but this causes the match to fail because they do not trim the spaces before compairing the values. Despite the fact that there is a well visited, sticky post on thier forum explaining the issue, the developers appear totally unwilling to take the few seconds it would require to add an RTRIM to the header parsing script. Even after manually trimming the values, the resulting MailHosts listing apparently shows every domain ever registered to your IP address rather than your current domain or RIP. This is confusing at best and is not mentioned in any documentation I could find. combined with the fact that SpamCOP keeps blocking innocent gmail users leads me to believe that since IronPort took over, SpamCOP has gone to heck. Use This pages remains for historical purposes.

A VBS SPAM reporting script for MS Outlook automatically do all the reporting for emails that I see ARE SPAM and that I place in a "spam" folder in Outlook.

It will report the spam to spamcop.net, retrieve the result, extract the form elements, approve the default options and actually trigger the sending of the spam reports. It will then log the result, move the message to an "oldspam" folder and go on to the next spam.

The idea is that as spam comes in, I just move it to the spam folder. At night, a scheduled job runs this script via the command line
cscript ol-spam-rpt.vbs //Nologo >> spamlog.html
and logs the results. I don't think spam reporting can get any easier... With the recent security "upgrades" my MS, I can't do it at night anymore.. I have to answer this stupid little box:

This is now a project... http://sourceforge.net/projects/ol-vbs-spam-rpt/ as is was spamcop http://sourceforge.net/projects/spamcop/

Keep in mind that you must have the Collaborative Data Objects option installed with Outlook. If you run the installer for Outlook or Office, go into the advanced options, you will find this item.

2004.12.21 Now incorporates past (unreported) spams and works with any sort of SpamCop account.

ol-spam-rpt.vbs:

function urlenc(astr)
dim i, c, e
	for i = 1 to len(astr)
		c = mid(astr,i,1)
		
		if C = " " then
			urlenc = urlenc & "+"
		elseif (c >= "0" and C <= "9") or (c >= "a" and C <= "z") or (c >= "A" and C <= "Z") then
			urlenc = urlenc & c
		else 
			urlenc = urlenc & "%" & right( "00" & hex( asc(c) ) , 2)
			end if
		next
	end function
			
 'wscript.stdout.write urlenc(")(ABC* & * ^ $^%$*&)(*")

function GetHTMLAttrib(anAttrib, aString)
	GetHTMLAttrib = ""
	on error resume next
	GetHTMLAttrib = split(aString,anAttrib&"=")(1)
	if left(GetHTMLAttrib,1)=chr(34) then GetHTMLAttrib = mid(GetHTMLAttrib,2)
	if instr(GetHTMLAttrib,"""")>0 then GetHTMLAttrib = split(GetHTMLAttrib,"""")(0)
	end function

wscript.stdout.write chr(13)&chr(10)&"<P> <A TITLE="&chr(34)&"Started:"&Now()&chr(34)&">-</A>"

olFolderInbox = 6
'Set objXhttp = Wscript.CreateObject("Msxml2.ServerXMLHTTP.4.0")
'ServerXMLHTTP.4.0 doesn't seem to be able to post data to the site. 
Set objhttp = Wscript.CreateObject("Microsoft.XmlHttp")
wscript.stdout.write "<A TITLE="&chr(34)&"Got XMLHTTP"&chr(34)&">-</A>"

Set objSession = Wscript.CreateObject("MAPI.Session")
objSession.Logon , , False, False
wscript.stdout.write "<A TITLE="&chr(34)&"Got MAPI.Session"&chr(34)&">-</A>"
Set ol = Wscript.CreateObject("Outlook.Application")
wscript.stdout.write "<A TITLE="&chr(34)&"Got Outlook.Application"&chr(34)&">-</A>"
Set olns = ol.GetNameSpace("MAPI")
wscript.stdout.write "<A TITLE="&chr(34)&"Got MAPI Namespace"&chr(34)&">-</A>"
Set MyFolder = olns.GetDefaultFolder(olFolderInbox).Folders("spam")
wscript.stdout.write "<A TITLE="&chr(34)&"Got SPAM folder"&chr(34)&">-</A>"
Set myDestFolder = MyFolder.Folders("oldspam")
wscript.stdout.write "<A TITLE="&chr(34)&"Got oldspam folder"&chr(34)&">-</A>"
Set fs = CreateObject("Scripting.FileSystemObject")


' Get the number of items in the folder.
NumItems = MyFolder.Items.Count
' Set MyItem to the collection of items in the folder.
Set MyItems = MyFolder.Items
DIM myMsgs()
REDIM PRESERVE myMsgs(NumItems)
I = 0
for each myItem in MyItems
	I = I + 1
	wscript.stderr.WriteLine I & " " & myItem.Subject
	set myMsgs(I) = myItem
	next
' Loop through all of the items in the folder.
For I = 1 to NumItems
'for each myMsg in myMsgs
  Set MyMsg = MyMsgs(I)
   if datediff( "d", MyMsg.ReceivedTime, now() ) >= 3 then
	wscript.stderr.write chr(13)&chr(10)&" - "&myMsg.ReceivedTime & " " & chr(34)& myMsg.Subject & chr(34) & " TOO OLD!"
	MyMsg.Delete
   else
	strEntryID = MyMsg.EntryID
	wscript.stdout.write chr(13)&chr(10)&"<P> <A TITLE="&chr(34)&strEntryID&chr(34)&">-</A>"
	strStoreID = MyMsg.Parent.StoreID
	Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)
'	Set myStream = objCDOMsg.GetStream 'don't work in OL98
'	myStr = ""
'	j = 1
'	for each myfield in objCDOMsg.Fields
'		if myField.ID = 8192030 then
'		myStr = myStr & chr(13)&chr(10) & j & myField.Name & "(" & myField.ID&")"&"-" &myfield.Value
'		end if
'		MsgBox MyMsg.Subject & myStr
'		myStr = ""
'		j = j + 1
'		next
'	MsgBox MyMsg.Subject & myStr
	on error resume next
	mySubject = split(myMsg.Subject & "**SPAM ", "**SPAM")(0)
	wscript.stderr.write chr(13)&chr(10)&" - "&myMsg.ReceivedTime &" " &datediff( "d", MyMsg.ReceivedTime, now() )& " " & chr(34)& mySubject & chr(34) & " "
	wscript.stdout.write "<B>"&MyMsg.ReceivedTime & " </B><I>"""&mySubject&"""</I>"
	myStr = objCDOMsg.Fields.Item(8192030) 'this is the raw headers
	myStr = replace(myStr, myMsg.Subject, mySubject)
	myStr = replace(myStr, "Post.Office MTA v3.5.3", "MetaMail v1.2" )

	myStr = myStr & chr(13)&chr(10) & objCDOMsg.Fields.Item(269680670) 'this is the raw html (only for HTML encoded messages)
	on error goto 0
	myStr = myStr & objCDOMsg.Text	'this is the raw text
	truncatemsg = chr(13)&"[truncated by SpamCop]"&chr(13)
	if len(myStr)>50000 then myStr = left(myStr, 50000-len(truncatemsg))&truncatemsg
'	myStr = "action=submit&oldverbose=&spam="&myStr&"&submit=x1"
	myStr = "action=submit&oldverbose=1&spam="&urlenc(myStr)&"&submit=x1"
	Set a = fs.CreateTextFile("spam0.txt", True)
	a.Write(myStr)
	a.Close
	startTime = Now()
	wscript.stdout.write "<A TITLE="&chr(34)&"askspamcop"&chr(34)&">-</A>"
'	wscript.stdout.write urlenc(myStr)
'	objhttp.open "POST", "http://mailsc.spamcop.net/sc", FALSE, "jamesnewton@spamcop.net", "password"
	objhttp.open "POST", "http://www.spamcop.net/sc", FALSE
'http://spamcop.net?code=CBxs1Qp8k8mTE5mm 
	objhttp.setRequestHeader "EncodeingType", "multipart/form-data"
	objhttp.setRequestHeader "ContentType", "text/plain"
	objhttp.send(myStr)
	myStr = objhttp.responseText
	ID = GetHTMLAttrib("/sc?id",myStr)
	wscript.stderr.write " id='"&ID&"'"
	Set a = fs.CreateTextFile("spam1.txt", True)
	a.WriteLine("ID: "&ID&chr(13)&chr(10) )
'	a.WriteLine(objhttp.statusText)
'	a.WriteLine(objhttp.getOption(-1))	
		'getOption(-1) returns the actual URL *after* the redirection
		'but generates an error with Microsoft.XmlHttp object
'	a.WriteLine(chr(13)+chr(10))
'	a.WriteLine(objhttp.getAllResponseHeaders())
	a.WriteLine(myStr)
	a.Close
	dResp = datediff("s",startTime,now())
	wscript.stdout.write "<A TITLE="&chr(34)&"id="&ID&" in "&dResp&"s"&chr(34)&">-</A>"
	if dResp > 45 then 
		wscript.stderr.write " Spamcop is loaded. Reply took:"& dResp &" seconds. Try later."
		wscript.quit
		end if
	while ID = Empty and dResp < 120
		wscript.stderr.write " Waiting for un-reported"
		wscript.stdout.write "<A TITLE="&chr(34)&"backthen="&backthen&chr(34)&">-</A>"
		backthen = now()
		tick = now()
		do 
			
			if DateDiff("s",tick,now()) > 0 then 
				tick = now()
				wscript.stderr.write "."
				end if
			loop while DateDiff("s",backthen,now()) < 10
		wscript.stdout.write "<A TITLE="&chr(34)&"now()="&now()&chr(34)&">-</A>"
		objhttp.open "GET", "http://www.spamcop.net", FALSE
		objhttp.send("")
		myStr = objhttp.responseText
		ID = GetHTMLAttrib("/sc?id",myStr)
		wscript.stderr.write " id='"&ID&"'"
		Set a = fs.CreateTextFile("spam2.txt", True)
		a.WriteLine("ID: "&ID&chr(13)&chr(10) )
'		a.WriteLine(objhttp.statusText)
'		a.WriteLine(objhttp.getOption(-1))		'getOption(-1) returns the actual URL *after* the redirection
'		a.WriteLine(objhttp.getAllResponseHeaders())
		a.Write(myStr)
		a.Close
		dResp = datediff("s",startTime,now())
		wend

	if instr(myStr, "spamid")<1 AND ID<>Empty then 'go get the past report
		wscript.stderr.write " Getting saved report"
		objhttp.open "GET", "http://www.spamcop.net/sc?id="&ID, FALSE, "jamesnewton@spamcop.net", "password"
		objhttp.send("")
		myStr = objhttp.responseText
		Set a = fs.CreateTextFile("spam3.txt", True)
		a.Write(myStr)
		a.Close
		end if
	myStr = split(myStr&ID&" ", ID,2)(1)
	wscript.stderr.write ". Reporting to: "
	if instr(myStr, "spamid")>0 then 
	'	myStr = "<input type=""hidden"" name=""action"" value=""flexsend"">"
		sendStr = ""
		urlStr = "http://www.spamcop.net"
		for each myStr in split(replace(myStr,"<","><"),">") '>
			if left(myStr,1) = "<" then
				if instr(1, myStr, "action=display", 1) > 0 then
					idLinkStr = replace(urlStr & GetHTMLAttrib("href", myStr),"&action=display","")
					end if
				select case ucase(split(mid(myStr,2))(0))
					case "FORM"
						urlAction = GetHTMLAttrib("action", myStr)
						if left(urlAction,4)="http" then urlStr = urlAction else urlStr = urlStr & urlAction
						methodStr = ucase(GetHTMLAttrib("method", myStr))
					case "INPUT"
						typeStr = GetHTMLAttrib("type", myStr)
						if typeStr = "checkbox" and instr(1,myStr, "checked",1)>0 then 
							sendStr = sendStr &"&"&GetHTMLAttrib("name", myStr) &"="
							sendStr = sendStr &"on"
						elseif typeStr = "submit" then
'							if GetHTMLAttrib("name",myStr) = empty then 
'								sendStr = sendStr &"&submit="
'								sendStr = sendStr &urlenc(GetHTMLAttrib("value", myStr))
'								end if
						elseif instr(myStr,"imaphost.com") then
							wscript.stderr.write "NOT Cybervalince "
						else
							sName = GetHTMLAttrib("name", myStr)
							sendStr = sendStr &"&"&sName&"="
							sValue = GetHTMLAttrib("value", myStr)
							sendStr = sendStr &urlenc(sValue)
							if sName = "source" then wscript.stdout.write chr(13)&chr(10)&"<BR>Source:"&sValue
							if instr(sValue, "@") then wscript.stderr.write sValue&"; "
							end if
					case "TEXTAREA"
						sendStr = sendStr &"&"&GetHTMLAttrib("name", myStr) &"="
					case "SELECT"
					case "OPTION"
					case "/SELECT"
					case "/FORM"
					case else
					end select
			else
				end if
			next
		wscript.stdout.write chr(13)&chr(10)&"<BR><A HREF="""&idLinkStr&""">"&idLinkStr&"</A>"

		objhttp.open methodStr, urlStr, FALSE, "jamesnewton@spamcop.net", "password"
'		objhttp.open methodStr, urlStr, FALSE, "", ""
'		objhttp.setRequestHeader "ContentType", "application/x-www-form-urlencoded"
'		objhttp.setRequestHeader "ContentType", "text/html;charset=UTF-8"
		objhttp.setRequestHeader "ContentType", "multipart/form-data"
		objhttp.send(mid(sendStr,2))
		myStr = objhttp.responseText
		Set a = fs.CreateTextFile("spamrep.txt", True)
		a.WriteLine(methodStr)
		a.WriteLine(urlStr)
		a.WriteLine(mid(sendStr,2)&chr(13)&chr(10))
		a.WriteLine(objhttp.statusText&chr(13)&chr(10))
'		a.WriteLine(objhttp.getAllResponseHeaders())
		a.Write(myStr)
		a.Close
		myStr = split(myStr, "<p>")(1)
		wscript.stdout.write chr(13)&chr(10)&"<BR>"&myStr&"</P>"
	else
		wscript.stdout.write chr(13)&chr(10)&"Rejected: <BR>"
		wscript.stderr.write chr(13)&chr(10)&"Rejected"
		e=instr(1,myStr, "<p>"&chr(10)&"<font color=""red"">",1)
		if e > 0 then wscript.stdout.write split(mid(myStr,e)&"</font> ","</font>")(0)&"</font>"
		e=instr(1,myStr, "error:",1)
		if e > 0 then 
			wscript.stdout.write split(mid(myStr,e)&"<br> ","<br>")(0)&"<br>"
			wscript.stderr.write split(mid(myStr,e)&"<br> ","<br>")(0)
			end if
		end if
	myMsg.Move myDestFolder
'	wscript.quit
	end if
   Next
next

2004.04.13 Confirmed to work in Outlook 2003, although Outlook has this annoying tendancy to ask you if it is ok all the time.

2002.08.13 Updated the script to include debug info in the log file as html anchor text so that you can mouse over the -'s in IE and see the messages. It is also now confirmed to work in Outlook 2000 on Windows XP.