'Atuhor Felipe 21/11/2007
'Version 7.0
'based on: Lorenzo Stefani autodisable.vbs
'Set 3 levels of DisableAct, level 0 nothing, 1 REDUCE MAX RECIPIENT, 2 Disable /add to BL
'Get Top SPammers/Emailers and Send Output Via Email
'DEFAULT Set Lower Max Recipient / Put In Exchange BlackList / Disable /
'Check whitelist before adding to DB, if in whitelist dont consider...

Const ForReading=1,ForWriting=2,ForAppending=8,adLockOptimistic = 3,adOpenDynamic = 1
Const adOpenStatic = 3
Const adUseClient = 3
Dim DisabledUPNS,sFile 
Dim t1, runtime
t1 = Timer  'time the script
dim strScriptFile : strScriptFile = WScript.ScriptFullname
dim sPath : sPath = Left(strScriptFile, Len(strScriptFile) - Len(WScript.Scriptname)) 
dim giorno, anno, mese, nomelog, i,strQuery, timer, trovato, Body
Dim SpammersCnt : SpammersCnt = 0
Dim cntAddBl : cntAddBl = 0
'______________LOGPARSER
Dim objLogParser : Set objLogParser = CreateObject("MSUtil.LogQuery")
Dim objInputFormat : Set objInputFormat = CreateObject("MSUtil.LogQuery.W3CInputFormat")	
Dim objOutputFormat : Set objOutputFormat = CreateObject("MSUtil.LogQuery.CSVOutputFormat")
''______________DB FORMAT: DATE,UPN,COUNT
Dim arrFields(2)
Dim arrValues
arrFields(0) = "DATE"
arrFields(1) = "UPN"
arrFields(2) = "COUNT"
'@@@@@@@@@@EDIT@@@@@@@@@@@@@
Dim Verbose : Verbose = 0			'=1 Display Msgs, =0 QUIET MODE
Dim DisableAct : DisableAct = 0    'Disable Accounts = 2, Will first try to Disable OR add to Excahnge BL, =1 Will Set MaxRecipient to intRlimit
Dim intRLimit : intRLimit = 20      'Max Recipient Limit To be set
Dim intSpamMin : intSpamMin = 500  'More then 500 a day(24hr) is considered SPAMMER
Dim intTopSpam : intTopSpam = 5     'How many of Top Spammers to report
Dim intDaySpam : intDaySpam = 1     'How many days ago to check (ONLY SAME MONTH)
Dim strMailServer : strMailServer = "mail.com"
Dim strEmailFrom : strEmailFrom = "mymail@coco.com" 
Dim strEmailTo : strEmailTo = "monitor@coco.com"
Dim strLDAP : strLDAP = "'" & "LDAP://DOMAINCONTROLLET.com.dsl.net/DC=com,DC=dsl,DC=net" & "'"
'@@@@@@@@@@FILE NAMES@@@@@@@@
Dim strDB : strDB = sPath & "SpamDB.mdb"          ' name and location of access file
Dim strDBTable : strDBTable = "SPAMCOPOUT"
dim whitelist : whitelist  = "whitelist.txt"	  'WHITELIST, conatins UPNs allowed to send 
Dim blacklist : blacklist =  "senderfilter.ldf"	  'UPNs that will go to Ex BL
Dim strFileTop : strFileTop = "TopSpammers.txt"
Dim outputfile : outputfile = sPath & "logs\Spammers_COCO_"& cstr(day(now())-intDaySpam) &"_" & cstr(Month(now()))&".txt"
'@@@@@@@@@@EDIT END@@@@@@@@@@@@@

'_____________SMTP OUT
	Dim serverOUT(3)
	serverOUT(0) = "SMTPOU01B01"
	serverOUT(1) = "SMTPOU01B02"
	serverOUT(2) = "SMTPOU01B03"
	serverOUT(3) = "SMTPOU01B04"	
	
'________________________MAIN CALLS___________
call main()
body = body & vbcrlf & vbcrlf &" Top " & intTopSpam & " Spammers of " & date - intDaySpam & vbcrlf
call TotalSpams(outputfile)
if SpammersCnt <> 0 then
 call uDB(strFileTop)
 call queryDB(date - intDaySpam ,intTopSpam)
 call DisplayMSG(DisabledUPNS)   'Print on Screen
end if

if cntAddBl <> 0 then 'To add into Exchange BL
	Call CloseBlackList()	
end if

'_________________________MAIN CALLS___________
RunTime = Timer  - t1
RunTime = Left(RunTime, 4)
body = body & vbCrlf & DisabledUPNS
body = body & vbCrlf & "Found " & SpammersCnt & " spammers"
'body = body & vbCrlf & "Done in : " & Runtime & " seconds."
if SpammersCnt <> 0 then
	call SendMail(strEmailFrom,strEmailTo,"","HSN Top Spammers",Body,outputfile)	
	
End if
wscript.quit



'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FUNCTIONS AND SUBS@@@@@@@@@@@@@@@@@@@@@
Sub Main
'Does the Querying In Remote Servers
	nomelog = GetFormatedDate(date)
	'Export UPN already in BlackList  to blacklist.txt	
	i= 0
	For i = 0 To UBound(serverOUT)

	if serverOUT(i) <> "" then
		sFile = sPath & "logs\log_" & serverOUT(i) & ".txt" 			
		strQuery ="SELECT sender-address as sa, Count(*) as Hits into " & sFile & "  FROM \\" & serverOUT(i) & "\" & serverOUT(i) & ".log\" & nomelog & ".log WHERE event-id = '1031' group by sender-address having count(*) > " & intSpamMin & " order by hits desc"
		call DisplayMsg( "Querying : " & serverOUT(i) & " SMTP LogFile : " & nomelog & ".log , for over " & intSpamMin & " emails sent" )
		'Call DisplayMsg(strQuery)
		body = body & vbCrlf & "Querying : " & serverOUT(i) & " SMTP LogFile : " & nomelog & ".log , for over " & intSpamMin & " emails sent" 
		objLogParser.ExecuteBatch strQuery, objInputFormat, objOutputFormat	
		call ParseResult(sFile,outputfile,"clean")
	end if
	next
end sub


Function ParseResult(inFile, outFile, strType)
'Parse logparser output and put into a txt
'Case to define what to parse
on error resume next
  Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
  Dim obj2FSO : Set obj2FSO = CreateObject("Scripting.FileSystemObject")
  Dim oFileOut, oFileIn 
  dim blnanswer
 'Open Out File For Creating/Appending
    If objFSO.FileExists(outFile) = false Then
         Set oFileOut= objFSO.CreateTextFile(outFile, True)        
   Elseif objFSO.FileExists(outFile) = true Then
        Set oFileOut= objFSO.OpenTextFile(outFile, ForAppending, True)        
   End If
 'Open In File For Reading
  If objFSO.FileExists(inFile) = true Then  
        set	oFileIn = objFso.OpenTextFile(inFile, ForReading)       
    select case LCase(strType)
        case "clean"    
            Do While Not oFileIn.AtEndOfStream	
			strLine = oFileIn.ReadLine
		
			if instr(strLine, "@") Then	
					strline = Replace(strLine, "-,",",")
					strline = Trim(strLine)					
'Call RegEx To get CLEAN EMAIL ADDRES
					strUPN = GetEmail(strLine)	
					arrLine = Split(strLine,",")				
					if strUPN="" then 													
						strUPN = arrLine(0)
					end if
					strUPN = Trim(strUPN)	
					if instr(strUPN, ".nll") then
						strUPN = replace(strUPN, ".nll",".nl")
					elseif instr(strUPN, ".de") then
						strUPN = replace(strUPN, ".de",".net")
					end if
'CHECK IF NOT IN WHITE LIST
					blnAnswer = CheckIfWhite(strUPN)					
					if blnAnswer=false then
						oFileOut.WriteLine strUPN &	";" & trim(arrLine(1))
						Call DisplayMsg("|"& strUPN &"|"& trim(arrLine(1))&"|")
						SpammersCnt	= SpammersCnt + 1
					elseif blnAnswer=true then
						DisabledUPNS = DisabledUPNS & vbCrlf & "|"& strUPN &"|"& trim(arrLine(1))&"|WHITELISTED|"						
						Call DisplayMsg("|"& strUPN &"|"& trim(arrLine(1))&"|WHITELISTED|")
					end if
			 end if		
		Loop				
		'Loop to read thru inFIle		
		'NEVER USED YET,maybe not needed
		Case "OTHERS"		
	    End select  	    
	End If 'inFile Check 
	oFileIn.Close 'close scan txt
	oFileOut.Close 'close scan txt  
    Set objFSO = Nothing
end Function

Function GetFormatedDate(inputDate)
 Dim intMonth : intMonth = Right("00" & Month(inputDate), 2)
 Dim intDay : intDay = Right("00" & Day(inputDate), 2) 
 intDay = intDay - intDaySpam 
 if len(intDay) = 1 then
 intDay = 0 & intDay  
 end if
 
 Dim intYear : intYear = Year(inputDate)
 GetFormatedDate = intYear & intMonth & intDay
End Function


'___________PART 2 ->  Function Regarding OUTPUT, DB, FORMATING, Etc...
function TotalSpams(CountFile)
'Goes thru Text File and Counts total of Emails sent from each email and Puts INTO A single line in a new Text File
	Dim oFS       : Set oFS     = CreateObject( "Scripting.FileSystemObject" )	
	Dim dicSpam   : Set dicSpam = CreateObject( "Scripting.Dictionary" )
	Dim oTS, aParts, sKey
	 IF OFS.FileExists(CountFile)= false then
	  Call DisplayMsg("File " & outputfile & " not Found")
	  exit function
	 end if
	Set oTS = oFS.OpenTextFile(CountFile)
	Do Until oTS.AtEndOfStream
		aParts = Split( oTS.ReadLine(), ";" )		
		aParts(0) = RTrim(aParts(0))				
		if UBound(aParts)=1 and isNumeric(aParts(1))=true then
			dicSpam(aParts(0)) = CStr(CLng(aParts(1)) + dicSpam(aParts(0)))
		end if
	Loop
	oTS.Close
	Set oTS = oFS.CreateTextFile(strFileTop)
	For Each sKey In dicSpam.Keys			   
		oTS.WriteLine date - intDaySpam  & ";" & trim(sKey) & ";"& dicSpam(sKey)		
	Next
	oTS.Close
	set oFS = Nothing
	set dicSpam = nothing
end function






Sub uDB(txtfile)
'Updated DB from a TXT file (uses updateDB function)	
	Dim linein, ifile
	Dim iFSO : Set iFSO = CreateObject("Scripting.FilesyStemObject")
	   Call DisplayMsg( "Processing file : " & txtfile)
	   Set ifile = iFSO.OpenTextFile(txtfile)  				
	   Do until ifile.AtEndOfLine 
	        linein = ifile.ReadLine			
			ReDim arrValues(2)
	        arrValues = Split(linein, ";", 3 )			
			arrValues(1) = trim(arrValues(1))			    
			if arrValues(0) <> "" then
			call updateDB(arrFields,arrValues)
			end if
			wscript.sleep 500
		 loop
end Sub

sub updateDB(arr1,arr2)	
'Updated DB, using array
    err.clear
	on error resume next
	Dim objConn : Set objConn = CreateObject("ADODB.Connection")
	objConn.Provider="Microsoft.Jet.OLEDB.4.0"	
	objConn.Open strDB
	Dim objRS : Set objRS = CreateObject("ADODB.Recordset")
	strSQL = "SELECT * FROM " & strDBTable 
	objRS.Open strSQL, objConn, 3, 3
	objRS.AddNew arr1, arr2
	objRS.Update
	objRS.Close	
	If err.number <> 0 Then 
	 Call DisplayMsg( "Error occurred connecting to the database " & strDB & " , ERROR: " & err.number)
	 exit sub
	end if
	objConn.Close
	set objRS = Nothing
	set objConn = Nothing
End sub



Function GetEmail(strString)
    Dim RegEx,arrMatches
    Set RegEx = New RegExp
    RegEx.IgnoreCase = True
    RegEx.Global=True                   
    RegEx.Pattern="\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
    Set arrMatches=RegEx.Execute(strString)
    For Each item In arrMatches
        strResults=strResults & " "& item.value
    Next
    GetEmail=strResults
End Function



'------------------------------------------------------------------------
' Sub Sendmail
'------------------------------------------------------------------------
Sub SendMail(sFrom,sTo,sCC,sSub,sBody,sAttch)
	on error resume next
	err.clear
	Dim objEmail : Set objEmail = CreateObject("CDO.Message")
	objEmail.From = sFrom
	objEmail.To = sTo
	ObjEmail.CC = sCC
	objEmail.Subject = sSub
	objEmail.Textbody = sBody
	objEmail.AddAttachment sAttch
	objEmail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
	objEmail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer
	objEmail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
	objEmail.Configuration.Fields.Update	
	objEmail.Send
	if err.number <> 0 then
			Call DisplayMsg( "Error sending email : " & err.descprition)
			wscript.quit
		end if
end sub



Sub QueryDB(day,top)
'Queries DB based on Day and TOP Spammers (how many to output)
'should Also form email body and call disable for all top 5 upn
	Dim objConn : Set objConn = CreateObject("ADODB.Connection")
	Dim objRS : Set objRS = CreateObject("ADODB.Recordset")
	objRS.CursorLocation = adUseClient	
	Call DisplayMsg( "Querying day " & day & " top " & top)
	Dim strSQL : strSQL = "SELECT DISTINCT TOP "& top &" UPN, COUNT FROM " & strDBTable & " WHERE DATE = '"& day &"' ORDER BY COUNT DESC"		
	If QueryTable(objConn, objRS, strSQL) Then        
     ' display the record count
     Call Displaymsg( "Record count:  " & objRS.RecordCount)
     ' loop through all records returned
    body = body & vbCrlf & String( 70, "-" )
	body = body & vbCrlf & "Data        ; Emails Sent ; Email Address"
	Call DisplayMsg( String( 70, "-" ))
	Call DisplayMsg("Data        ;  Emails Sent  ;  Email Address")
     Do Until objRS.EOF
         Call DisplayMsg(     date - intDaySpam  & "  ;  " & FormatNumber(objRS.Fields.Item("COUNT"),0) & "  ;  " &  objRS.Fields.Item("UPN"))
		 body = body & vbCrlf  & date - intDaySpam  & "  ;  " & FormatNumber(objRS.Fields.Item("COUNT"),0) & "  ;  " &  objRS.Fields.Item("UPN")
		if DisableAct = 2 then        
			call Disable(objRS.Fields.Item("UPN"))		 
		elseif DisableAct = 1 then        
		     call SetMaxRecipient(objRS.Fields.Item("UPN"))
		end if
		 objRS.MoveNext
     Loop
	 Else
     Call DisplayMsg( "No record found matching you query!")
     End If
	 Call DisplayMsg( String( 70, "-" ))
	 body = body & vbCrlf & String( 70, "-" )
 ' close connections
 objRS.Close
 objConn.Close
End Sub

Function QueryTable(objConn, objRS, strSQL)
'Queries the Table verifies query result is <> NULL 'Use with QueryDB
 objConn.Open "Provider = Microsoft.Jet.OLEDB.4.0; Data Source=" & strDB
 objRS.Open strSQL, objConn, adOpenStatic, adLockOptimistic
 ' if the query returns a value then move to the first record & return true
 If Not objRS.EOF Then 
     objRS.MoveFirst
     QueryTable = True
 Else
     ' return false if query do not return anything
     QueryTable = False
 End If
End Function

'_____________________________FUNCTIONS REGARDING DISABLE ACT/ADD EX BL ___________

Sub Disable(strUPND)
'Check in AD if UPN is already Disabled
'Otherwise go ahead and disable it
	err.clear
	'on error resume next
	'Check if UPN is empty or If it is in WHITELIST
	if strUPND = "" or CheckIfWhite(strUPND)=true then		
		call DisplayMsg("IN WHITELIST")
		exit sub
	end if    		
	call displaymsg("Checking: " & strUPND )
	Const ADS_UF_ACCOUNTDISABLE = 2	
	Dim WshNetwork : Set WshNetwork = WScript.CreateObject("WScript.Network")
	Dim con : Set con = CreateObject("ADODB.Connection")
	con.Provider = "ADsDSOObject"
	con.open
	Dim command : Set command = CreateObject("ADODB.Command")
	Set command.ActiveConnection = con
	command.CommandText = "SELECT * FROM " & strLDAP & " WHERE mail = '" & strUPND & "'"
	command.Properties("searchscope") = 2
	Dim rs : Set rs = command.Execute
	'check for errors
	if err <> 0 then
		Call DisplayMSG( "ERROR : " & err.description)
	end if
	If rs.EOF then 
		DisabledUPNS = DisabledUPNS & " Account: '" & strUPND & "' Not found in AD." & vbCrLf	    
		'ADD TO EXCHANGE BLACK LIST EXPORT .LDF
		call FBlackList(strUPND)
	Else
	Set UserObject = GetObject((rs("ADsPath")))
	If UserObject.AccountDisabled=True Then
		DisabledUPNS = DisabledUPNS & strUPND & " account is already DISABLED." & vbCrLf		
	Else
'DISABLE ACCOUNT
		userobject.userAccountControl = 66050
		userobject.SetInfo
		DisabledUPNS = DisabledUPNS & strUPND & " DISABLED" & vbCrLf		
	end If
	end If
	set con = nothing
	Set WshNetwork = nothing
end sub


Function CheckIfWhite(strEMAIL)
'Check if in WhiteList, shuold parse dirty emails, with -
 Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
 Dim wLine
 if objFSO.FileExists(whitelist) = false Then
	call displayMsg("WhiteList file NOT FOUND!")
	exit function
 end if
 Dim oWhite : Set oWhite = objFSO.OpenTextFile(whitelist, ForReading)      
 Do While Not oWhite.AtEndOfStream	
	wLine = oWhite.ReadLine
	if instr(wLine, strEMAIL) Then
		call DisplayMsg(strEMAIL & " is in whitelist")			
		'DisabledUPNS = DisabledUPNS & strEMAIL & " is in whitelist"
		CheckIfWhite = true
		exit function		
	end if	
 loop 
 CheckIfWhite = false
 call displaymsg("WhitelistCheck: " & strEMAIL & " = " & CheckIfWhite)
 oWhite.close
 set objFSO = nothing
end Function

Sub FBlackList(Stringa)
On Error Resume Next    
	dim filesys, filetxt
	Set filesys = CreateObject("Scripting.FileSystemObject")	
	call displaymsg("Checking if in Whitelist " & Stringa )
	if filesys.FileExists(blacklist)= False then
	'If senderfilter.ldf  dont exists then Create one!
		call displaymsg("Creating Blacklist and adding " & Stringa & " to Exchange B.L.")
		Set filetxt = filesys.CreateTextFile(blacklist, True) 
		filetxt.writeline ("dn: CN=Default Message Filter,CN=Message Delivery,CN=Global Settings,CN=DC,CN=Microsoft Exchange,CN=Services,CN=Configuration,DC=DC,DC=local")
		filetxt.writeline ("changetype: modify")
		filetxt.writeline ("add: msExchTurfListNames")
		filetxt.writeline ("msExchTurfListNames: " & Stringa)
		cntAddBl = cntAddBl + 1
	elseif filesys.FileExists(blacklist)= True then
	'If senderfilter.ldf  exists just append
		Set filetxt = filesys.OpenTextFile(blacklist, ForAppending, True)
		filetxt.writeline ("msExchTurfListNames: " & Stringa)
		call displaymsg("Adding " & Stringa & " to Exchange B.L.")
		cntAddBl = cntAddBl + 1
		filetxt.Close 
	end if
    Set filesys = Nothing
    Set filetxt = Nothing	
End Sub

Sub CloseBlackList()
'On Error Resume Next
    Dim FSO,FSO2, fs ,ds, s
	dim filesys, filetxt	
	Set filesys = CreateObject("Scripting.FileSystemObject")
		Set filetxt = filesys.OpenTextFile(blacklist, ForAppending, True)
		filetxt.writeline ("-")
		filetxt.Close 	
    Set filesys = Nothing
    Set filetxt = Nothing
'execute import.bat		
	call exec("import.bat")
	wscript.sleep 300
	call exec("cmd /c del /q senderfilter.ldf")
end sub

function exec(execCmd)
	'on error resume next
	dim strCmd
	dim objShell : Set objShell = WScript.CreateObject("WScript.Shell")		
	strCmd = sPath & execCmd
	call DisplayMsg( strCmd	)
	Dim objExecObject : Set objExecObject = objShell.Exec(strCmd)	
	Do While objExecObject.Status <> 1		
		wscript.sleep 500			
	Loop	
	if err.number = 0 and objExecObject.Status = 1 then 				
		'call DisplayMsg("done")
	else
		call DisplayMsg("error")
	end if
end function


Function SetMaxRecipient(userName)
on error resume next
	Set WshNetwork = WScript.CreateObject("WScript.Network")
	UserName = ifile.ReadLine
	Set con = CreateObject("ADODB.Connection")
	con.Provider = "ADsDSOObject"
	con.open
	Set command = CreateObject("ADODB.Command")
	Set command.ActiveConnection = con
	command.CommandText = "SELECT * FROM " & strLDAP & " WHERE userPrincipalName = '" & UserName & "'"
	command.Properties("searchscope") = 2
	Set rs = command.Execute
	if rs.EOF then 	      
		  DisabledUPNS = DisabledUPNS & "Account: '" & UserName & "' Not found in OU, Max Recipient NOT SET" & vbcrlf
		  exit function
	end if
	Set UserObject = GetObject((rs("ADsPath")))	
	Call DisplayMsg( UserName & "  Max Recipiten Limit Set To: " & intRLimit )
	DisabledUPNS = DisabledUPNS &  UserName & "  Max Recipiten Limit Set To: " & intRLimit 
	'SET MAX RECIPIENT AD
	userobject.msExchRecipLimit = intRLimit
	userobject.SetInfo
	
	'CleanUP
	set con = nothing
	set command = nothing
	set WshNetwork = nothing
end function  


Function DisplayMsg(msgTxt)
'Prints msg on screen only if Verbose is set	
	if Verbose = 1 then		
		wscript.echo msgTXT
	end if
end Function