EXCHANGE TOP SPAMMERS/EMAILERS

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

EXCHANGE TOP SPAMMERS/EMAILERS

Logged in as: Guest

arrSession:exec spGetSession 2,16,53451

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> EXCHANGE TOP SPAMMERS/EMAILERS
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

EXCHANGE TOP SPAMMERS/EMAILERS - 11/12/2007 3:14:23 AM

4scriptmoni

Posts: 192
Score: 0
Joined: 5/3/2007
Status: offline

If you need to know who is the top emailers, or possibly spammers then this is the scritp!
Be sure to edit the fields.
Requires:
-> logparser.dll (regsvr32 logparser.dll)
-> Access MDB file: "SpamCopDB.mdb" with Text Fields: DATE, UPN, COUNT

Special thanks to EHVBS for all the help

'Atuhor Felipe 21/11/2007
'Version 7.0
'based on: Lorenzo Stefani autodisable.vbs
'DOWNLOAD LOGPARSER
'SAVE SCRIPT TO SHORT PATH like C:\SCRIPT, CREAT LOGS FOLDER PUT .MDB IN SAME FOLDER AS SCRIPT
'CREATE ACCESS .MDB WITH TABLENAME= SPAMCOPOUT AND FIELDS DATE, UPN,COUNT
'Set 3 levels of DisableAct, level 0 nothing, 1 REDUCE MAX RECIPIENT, 2 Disable /add to BL (There is also a WHITELIST!)
'Get Top SPammers/Emails Sent Out and Send Output Via Email (maybe task schedulle daily?)
'TO DO:
'1. Dynamic Configure Script (right now its to hard to set parameters by hand)
'1.A - auto download logparser.dll, spamDB.mdb  and register logparser.dll
'1.B - CREATE c:\script and c:\script\log (copy .vbs and .mdb files to c:\script)
'2.Discover exchange log files
'2.A - Find current Domain and autoget strLDAP
'2.B - Verify exchange log files are found
'3. Allow auto filling entire DB for this month (loop thru each file)
'4. Another Script to Generate Reports(weekly,monthly) TOP SENDERS
'5. Another Script to get emails IN, where is it comming from
'6. 'autocreate whielist.txt 
'7. Do not allow doubles into the DB (if script is ran for same day twice)
'8.  Make into an HTA, GUI and allow auto schedulle
on error resume next
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")
if err.number <> 0 then
wscript.echo "Be sure to download LogParser!! ERROR: " & err.description
wscript.quit
end if
''______________DB FORMAT: DATE,UPN,COUNT
Dim arrFields(2)
Dim arrValues
arrFields(0) = "DATE"
arrFields(1) = "UPN"
arrFields(2) = "COUNT"
'@@@@@@@@@@EDIT@@@@@@@@@@@@@
Dim Verbose : Verbose = 1   '=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 = 10      'Max Recipient Limit To be set
Dim intSpamMin : intSpamMin = 100  '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 = "SRVVLEXCHANGE"
Dim strEmailFrom : strEmailFrom = "[email=administrador@ge.com]administrador@ge.com[/email]" 
Dim strEmailTo : strEmailTo = "[email=administrador@ge.com]administrador@ge.com[/email]"
Dim strLDAP : strLDAP = "'" & "[link=http://www.visualbasicscript.com/ldap://GCSERVER.DOMAIN.local/DC=local]LDAP://GCSERVER.DOMAIN.local/DC=local[/link]" & "'"
'@@@@@@@@@@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 & "Spammers_Gencat_"& cstr(day(now())-intDaySpam) &"_" & cstr(Month(now()))&".txt"
'@@@@@@@@@@EDIT END@@@@@@@@@@@@@
'_____________SMTP OUT
Dim serverOUT(0)
serverOUT(0) = "SRERVER_EXCHANGE"

'________________________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,"","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
    'DisplayMsg strUpn
'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 "normal" 
 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) 
    DisplayMsg strUpn
  end if
 Loop
    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 _
   ("[link=http://schemas.microsoft.com/cdo/configuration/sendusing]http://schemas.microsoft.com/cdo/configuration/sendusing[/link]") = 2
objEmail.Configuration.Fields.Item _
   ("[link=http://schemas.microsoft.com/cdo/configuration/smtpserver]http://schemas.microsoft.com/cdo/configuration/smtpserver[/link]") = strMailServer
objEmail.Configuration.Fields.Item _
   ("[link=http://schemas.microsoft.com/cdo/configuration/smtpserverport]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/link]") = 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, just created one for you.")
   Set oWhite= objFSO.CreateTextFile(whitelist, True) 
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

< Message edited by 4scriptmoni -- 5/19/2008 1:24:10 AM >

_____________________________

Enterprise Microsoft Scripts
Exchange, Login/Logout Monitor,TS, Monitoring, Security, AD, etc...
http://www.felipeferreira.net

Revisions: 4 | Post #: 1

RE: EXCHANGE TOP SPAMMERS/EMAILERS - 5/29/2008 11:50:33 PM

4scriptmoni

Posts: 192
Score: 0
Joined: 5/3/2007
Status: offline

Dont need to create a DB or download, the script will do all that byitself,

Updated version is much more automated:
- Autocreate whielist.txt - OK
-Find current Domain and autoget strLDAP - OK
- Auto download logparser.dll, spamDB.mdb and register logparser.dll - OK
- CREATE c:\script and c:\script\log (copy .vbs and .mdb files to c:\script) OK

For now all Parameters needed to be set are:
strMailServer strEmailFrom , strEmailTo
Also check the parametrs for Number of emails a day to consider, for now Its set to 100, and will report only the top 5.

'Atuhor Felipe 21/11/2007 updated 27/05/08
'Version 8.0
'based on: Lorenzo Stefani autodisable.vbs

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
Dim objFSO

'@@@@@@@@@@DB FORMAT@@@@@@@@@@
Dim arrFields(2)
Dim arrValues
arrFields(0) = "DATE"
arrFields(1) = "UPN"
arrFields(2) = "COUNT"
'@@@@@@@@@@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 & "Spammers_"& cstr(day(now())-intDaySpam) &"_" & cstr(Month(now()))&".txt"

'@@@@@@@@@@----------EDIT-------------@@@@@@@@@@@@@
Dim Verbose : Verbose = 1            '=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, 0 DO NOTHING
Dim intRLimit : intRLimit = 10      'Max Recipient Limit To be set
Dim intSpamMin : intSpamMin = 100   '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 = ""
Dim strEmailFrom : strEmailFrom = "" 
Dim strEmailTo : strEmailTo = ""
Dim strLDAP ' NOW AUTOMATIC
'@@@@@@@@@@----------EDIT-------------@@@@@@@@@@@@@

'_____________SMTP OUT
   Dim serverOUT(0)
   serverOUT(0) = "SRVVLEXCHANGE"
   
'______________LOGPARSER

call GetLDAP()
call CheckDir()      'Verifit if running in C:\SCRIPTS if not Create and copy itself there
call CheckFiles()    'Verify if logparser.dll and SpamDB.mdb are present!

wscript.sleep 100
Dim objLogParser : Set objLogParser = CreateObject("MSUtil.LogQuery")
Dim objInputFormat : Set objInputFormat = CreateObject("MSUtil.LogQuery.W3CInputFormat")    
Dim objOutputFormat : Set objOutputFormat = CreateObject("MSUtil.LogQuery.CSVOutputFormat")

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,"","Top Spammers",Body,outputfile)    
   
End if
wscript.quit

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
 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
                   'DisplayMsg strUpn
'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 "normal"    
       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)    
                   DisplayMsg strUpn
           end if
       Loop
       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 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

'------------------------------------------------------------------------
' 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

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

Sub CheckFiles()
   Set objFSO = CreateObject("Scripting.FileSystemObject") 
   if instr(strScriptFile,"c:\scripts\") <> 0 then 
       DisplayMsg "Script must Run from c:\scripts\"
       wscript.quit
   end if
   If (objFSO.FileExists(spath & "logparser.dll")) Then 
    call DisplayMsg ("File logparser.dll OK...")
   else
    DisplayMsg "Downloading LogParser for you..."
    call GetFile("logparser.dll")     
    wscript.sleep 2200   'wait for file to arraive
    Set objShell = WScript.CreateObject( "WScript.Shell" ) 
    objShell.Run "regsvr32 /s " & spath & "logparser.dll", , True           
    call DisplayMsg ("File logparser.dll Downloaded OK")
   End If 
   Set objFSO = CreateObject("Scripting.FileSystemObject") 
   If (objFSO.FileExists(spath & "SpamDB.mdb")) Then 
   call DisplayMsg ("File SpamDB.mdb OK...")
   else
   DisplayMsg "Downloading SpamDB.mdb for you..."
    call GetFile("SpamDB.mdb")
    wscript.sleep 1200   'wait for file to arraive
    call DisplayMsg ("File SpamDB.mdb Downloaded OK")
   end if
   Set objFSO = CreateObject("Scripting.FileSystemObject") 
   If (objFSO.FileExists(spath & "whitelist.txt")) Then 
    call DisplayMsg ("File whitelist OK...")
   else
    objFSO.CreateTextFile("whitelist.txt") 
     call DisplayMsg ("File whitelist Created OK")
     
   end if
   
   set objFso = nothing
end sub

sub getLDAP()
   'Auto created the LDAP String for querying AD
   '// Create an instance of the wshShell object
   set WshShell = CreateObject("WScript.Shell")
   strDomain = WshShell.ExpandEnvironmentStrings("%USERDNSDOMAIN%")
   if strDomain = "" then 
       DisplayMsg "You are not in a Domain, this script will not work!"
       wscript.quit
   end if
   strLogonServ = WshShell.ExpandEnvironmentStrings("%LOGONSERVER%")
   arrDC = split(strDomain,".")
   strLogonServ = Right(strLogonServ,len(strLogonServ) - 2 )
   trim(strLogonServ)
   'This Auto Generate the LDAP String to connect to GC and Make a Query  WARNING: Might not work with long domain names like coco.ex.com.local 
   'FORMAT 'strLDAP = "'" & "LDAP://<GC>.<DOMAIN>.local/DC=local" & "'"
   strLDAP = "'" & "LDAP://" & strLogonServ & "." & strDomain & "/DC=" & arrDC(Ubound(arrDC)) &"'"
   'DisplayMsg StrLDAP
   set WshShell = nothing
end sub

sub GetFile(filename)
   Dim objMyFile, objShell, strFTPScriptFileName
   Dim strFileGet1, strFileGet2 
   Dim strFTPServerName, strLoginID 
   Dim strPassword, strFTPServerFolder 
   
   strFTPServerName = "xoroz.com" 
   strLoginID = "files@xoroz.com" 
   strPassword = "files" 
   strFTPServerFolder = "/"

'Generate FTP command 
   strFTPScriptFileName = spath & "FTP.txt" 
   Set objFSO = CreateObject("Scripting.FileSystemObject") 
   If (objFSO.FileExists(strFTPScriptFileName)) Then 
    objFSO.DeleteFile (strFTPScriptFileName) 
   End If 
   
   If (objFSO.FileExists(spath & "\" & filename)) Then 
     DisplayMsg "File " & filename & " already exists, will not replace, quiting..."
     wscript.quit
   End If 
   Set objMyFile = objFSO.CreateTextFile(strFTPScriptFileName, True) 
   objMyFile.WriteLine ("open " & strFTPServerName) 
   objMyFile.WriteLine (strLoginID) 
   objMyFile.WriteLine (strPassword) 
   objMyFile.WriteLine ("cd " & strFTPServerFolder) 
   objMyFile.WriteLine ("bin") 
   objMyFile.WriteLine ("lcd " & spath) 
   objMyFile.WriteLine ("prompt off") 
   objMyFile.WriteLine ("mget " & filename) 
   objMyFile.WriteLine ("disconnect") 
   objMyFile.WriteLine ("bye") 
   objMyFile.Close 
   
   'Execute the FTP script. 
   Set objShell = WScript.CreateObject( "WScript.Shell" ) 
   'call DisplayMsg( "ftp -s:" & Chr(34) & strFTPScriptFileName & Chr(34))
   'exec "cmd /c ftp -s:" & Chr(34) & strFTPScriptFileName & Chr(34)
   objShell.Run "ftp -s:" & Chr(34) & strFTPScriptFileName & Chr(34), , True      
   If (objFSO.FileExists(strFTPScriptFileName)) Then     
    objFSO.DeleteFile (strFTPScriptFileName) 
   End If  
   Set objFSO = Nothing 
   Set objMyFile = Nothing 
   Set objShell = Nothing 
end sub

sub CheckDir()
   'Copy itself to C:\scripts\   ( for many reasons the script dont run well on large paths so this should fix it)
   Set fso = CreateObject("Scripting.FileSystemObject")    
   
   if spath <> "c:\scripts\" and instr(strScriptFile,"c:\scripts\") = 0 and fso.FolderExists("c:\Scripts") = False then
       DisplayMsg strScriptFile 
       fso.CreateFolder "c:\scripts"
       fso.CreateFolder "c:\scripts\logs"
       Set fso = CreateObject("Scripting.FileSystemObject")
       Set c = fso.GetFile(strScriptFile)
       c.Copy("c:\scripts\ExGetTop5.vbs")
       DisplayMsg "Run Script from C:\scripts\ExGetTop5.vbs"        
       wscript.quit
       
   end if
   set c = nothing
   Set fso = nothing
end sub
Function CheckIfWhite(strEMAIL)
'Check if in WhiteList, shuold parse dirty emails, with -
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim wLine
if objFSO.FileExists(whitelist) = false Then
   call displayMsg("WhiteList file NOT FOUND, just created one for you.")
   Set oWhite= objFSO.CreateTextFile(whitelist, True) 
   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

_____________________________

Enterprise Microsoft Scripts
Exchange, Login/Logout Monitor,TS, Monitoring, Security, AD, etc...
http://www.felipeferreira.net

(in reply to 4scriptmoni)

Post #: 2

If you found our site useful please link to us <a href="http://www.visualbasicscript.com">VisualBasicScript.com</a>.

All Forums >> [Scripting] >> Post a VBScript >> EXCHANGE TOP SPAMMERS/EMAILERS

Page: [1]

Jump to:

New Messages	No New Messages
Hot Topic w/ New Messages	Hot Topic w/o New Messages
Locked w/ New Messages	Locked w/o New Messages

Post New Thread

Reply to Message

Post New Poll

Submit Vote

Delete My Own Post

Delete My Own Thread

Rate Posts