ASP/VBScript: Send E-Mail with CDO
I've used CDONTS for years, even though it hasn't been included in a Windows Server release since NT4. Anytime I needed to send mail, I'd copy over CDONTS.dll, register it then use my old CDONTS code. Not sure why I resisted it for so long.. I think the weird Configuration Fields were too odd to accept. But I've finally accepted them.. about 3 good years after ASP went out of style. Here's a less-than-timely code snippet:
This is the sound of settling.
Set objCDO = CreateObject("CDO.Message")
objCDO.Subject = "Update from Web App."
objCDO.From = "Web App <webapps@me.com>"
objCDO.To = "yomomma@gmail.com"
objCDO.TextBody = "Hello," & vbCrLf & vbCrLf & "A new order has been placed by " & userName & "."
objCDO.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort (1 = local, 3 = Exchange)
objCDO.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.me.com"
objCDO.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objCDO.Configuration.Fields.Update
objCDO.Send
set objCDO = NothingClassic ASP: "Push" File Downloads from A Directory Outside the Application Root
This is some super old code but I used it recently and figured I'd archive it on this site for my future reference. The sample code below aims to allow authenticated users to download files which are not available via direct download (ie. files within the web root). The script accomplishes this by doing the following:
1. Checks to see if the user is logged in (your method may vary)
2. Sets the root directory location
3. Checks to see if the file exists, if so...
4. Retrieves the filesize and adds the appropriate HTTP headers including content disposition, filename, content type and filesize.
5. Uses a binary stream to "push" the download
Save this file as download.asp and call it with the filename in the querystring. Example: http://domain.com/downloads/download.asp?filename=myfile.pdf. Also, be sure to give read permissions to IUSR_SvrName to the root directory. Change the authentication requirements as needed:
<%
If session("loggedIn") = True Then
strFilePath = "D:\webfiles\downloads" & request.querystring("filename")
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(strFilePath) Then
Set objFile = objFSO.GetFile(strFilePath)
intFileSize = objFile.Size
Set objFile = Nothing
strFileName = request.querystring("filename")
strFileName = replace(request.querystring("filename")," ","-")
Response.AddHeader "Content-Disposition","attachment; filename=" & strFileName
Response.ContentType = "application/x-msdownload"
Response.AddHeader "Content-Length", intFileSize
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Open
objStream.Type = 1 'adTypeBinary
objStream.LoadFromFile strFilePath
Do While Not objStream.EOS And Response.IsClientConnected
Response.BinaryWrite objStream.Read(1024)
Response.Flush()
Loop
objStream.Close
Set objStream = Nothing
Else
Response.write "Error finding file."
End if
Set objFSO = Nothing
End If
%>Note: Even if the file is a PDF and a third-party application such as Adobe Reader is set to open the file within the browser, the code below will override that and force a download (by using the "application/x-msdownload" content type).
[The UPDATE below is no longer accurate as an alternative solution has been given below in the comments and subsequently, was added to the code (Thanks a bunch, David!). I wanted to leave it for Googlers looking for a solution, however]
UPDATE: Someone wrote to let me know that they were encountering the error "Response Buffer Limit Exceeded". As it turns out, IIS 6's ASPBufferingLimit is set to a measly 4MB (4194304 bits) so any file over 4MB would produce this error. To fix this issue, you will have to have access to IIS either via the command line or the MMC. Here's how to change the buffering limit via the command line:
************ NOTE: An easier solution is to use the updated Do While/Flush procedure given in the code *****************
cd C:\inetpub\adminscripts
cscript adsutil.vbs set /w3svc/aspbufferinglimit 4294967295That's a buffering limit of more than 4 Gigabytes. Personally, I'd lop off the last digit and make that number closer to 430MB. Running that script worked immediately on my test machine, even though I do not have "Enable Direct Metabase Edit" checked in IIS' Properties. If it doesn't work for you, restart IIS and see if it works.
VBScript: Enumerate All SQL Servers on a Domain
So if you have SQL Server installed locally, you're lucky enough to have access to SQLDeeMO. You can then easily enumerate SQL Servers with the following code. Note: If you do decide to use VBScript and SQLDeeMO, you will need to remove the "ee" in the script below. I didn't want to put in the actual object name so that people searching Google for sites that do not contain the phrase SQLDeeMO will still find my site.
Set objSQLDMOApp = CreateObject("SQLDeeMO.Application")
Set objSQLList = objSQLDeeMOApp.ListAvailableSQLServers()
For i = 1 To objSQLList.Count
MsgBox objSQLList.Item(i)
Next
Set objSQLList = Nothing
Set objSQLDeeMOApp = NothingBut if you don't have SQL Server installed locally.. here's a hack that grabs the name of all Windows Servers in AD and then checks their registry for instances of SQL Server.
Enumerate All SQL Servers and Instance Names on a Domain
'****************************************************************************
' This script created by Chrissy LeMaire (clemaire@gmail.com)
' Modifications by Gregory Jones (greg@fuzsh.com) and Radsky
' Website: http://netnerds.net/
'
' This script finds all SQL Servers and their instances that are members of an AD domain
' and running any Windows Server version
'
' Run this script with admin privs on any computer within a domain
'
' This script has been tested on Windows Server 2003 and Server 2008.
' The newest script REQUIRES SQL Native Client to get the Version.
'
' "What it does"
' 1. Gathers all machines in a domain that are running a Windows Server OS (NT, 2000, 2003, 2008, etc)
' 2. Pings them to see if they are available
' 3. If they do respond to pings, it checks their registry to see if they have the proper SQL keys
' 4. If the key does exist, it then enumerates the instances (including default)
' 5. And then it goes get the version and architecture
'
' NO WARRANTIES, USE THIS AT YOUR OWN RISK, etc.
'*****************************************************************************
'on error resume next
Set objAdRootDSE = GetObject("LDAP://RootDSE")
Set objRS = CreateObject("adodb.recordset")
set objFS = CreateObject("Scripting.FileSystemObject")
Set objOutputText = objFS.CreateTextFile("sqlServers.txt")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Const HKEY_LOCAL_MACHINE = &H80000002
varConfigNC = objAdRootDSE.Get("defaultNamingContext")
strConnstring = "Provider=ADsDSOObject"
strWQL = "SELECT * FROM 'LDAP://" & varConfigNC & "' WHERE objectCategory= 'Computer' and OperatingSystem = 'Windows*Server*' "
objRS.Open strWQL, strConnstring
Do until objRS.eof
Set objServer = GetObject(objRS.Fields.Item(0))
strServerName = objServer.CN
Set colItems = objWMIService.ExecQuery("Select * from Win32_PingStatus Where Address = '" & objServer.DNSHostName & "'")
For Each objItem in colItems
If objItem.StatusCode = 0 Then 'The Computer is Pingable
Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strServerName & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Microsoft SQL Server"
strValueName = "InstalledInstances"
objRegistry.GetMultiStringValue HKEY_LOCAL_MACHINE,strKeyPath, strValueName,arrValues
If IsNull(arrValues) = 0 Then 'It's a SQL Server! Enumerate it's instances
For Each strValue In arrValues
if lcase(strValue) <> "mssqlserver" then strServerName = strServerName & "\" & strValue
strMsg = strServerName & vbtab & GetSQLServerVersion(strServerName)
objOutputText.WriteLine strMsg
Next
End If
Set objRegistry = Nothing
End If
Set objServer = Nothing
Next
objRS.movenext
Loop
objRS.close
objOutputText.close
Set objOutputText = nothing
Set objWMIService = Nothing
Set objRS = Nothing
Set objAdRootDSE = Nothing
Msgbox "Done!"
'####
Function GetSQLServerVersion(serverName)
on error resume next
strConn = "Driver={SQL Server};Server=" & serverName & ";Database=master"
strsql = "SELECT @@version"
set rs = createobject("adodb.recordset")
rs.Open strsql, strConn, 1, 1
if err.Number <> 0 then
GetSQLServerVersion = "Port blocked (Likely Desktop / Express)"
err.Clear
else
if not rs.eof and not rs.bof then
strVersion = rs(0).Value
if inStr(strVersion,vbLf) > 0 Then strVersion = left(strVersion,inStr(strVersion,vbLf))
GetSQLServerVersion = strVersion
else
GetSQLServerVersion = "Unknown Version"
end If
end if
rs.close
set rs = nothing
End Function '//Function GetSQLServerVersion(serverName)If you are looking for the version of each SQL Server.. you can either query it with SELECT @@VERSION or it may be easily found in the registry. It's 10:47pm and I'm still at work so I'm heading out 
VBScript: Use an LDAP Query to Find All Windows Servers on a Domain
Damn, the ADsDSOObject rocks! This script, which weighs in at less than 20 lines, finds all machines running any form of Windows Server on a given domain. Note that this script isn't useful in finding domain controllers, but rather any machine running Windows Server.
'****************************************************************************
' This script created by Chrissy LeMaire (clemaire@gmail.com)
' Website: http://netnerds.net/
'
' This script finds all machines running Windows Server (NT, 2000, 2003) in AD
'
'Msgbox output provides server name and OS version.
'
' NO WARRANTIES, USE THIS AT YOUR OWN RISK, etc.
'*****************************************************************************
Set objAdRootDSE = GetObject("LDAP://RootDSE")
Set objRS = CreateObject("adodb.recordset")
varConfigNC = objAdRootDSE.Get("defaultNamingContext")
strConnstring = "Provider=ADsDSOObject"
strWQL = "SELECT * FROM 'LDAP://" & varConfigNC & "' WHERE objectCategory= 'Computer' and OperatingSystem = 'Windows*Server*'"
objRS.Open strWQL, strConnstring
Do until objRS.eof
Set objServer = GetObject(objRS.Fields.Item(0))
strServerName = objServer.CN
strOperatingSystem = objServer.OperatingSystem
MsgBox strServerName & " is running " & strOperatingSystem
objRS.movenext
Set objServer = Nothing
Loop
objRS.close
Set objRS = Nothing
Set objAdRootDSE = NothingAlso, I found this nice reference of Command One Liners while searching the web. Totally handy!
VBScript: Find All Exchange Servers in Active Directory
My friend Sharfa and I were exchanging some of our favorite code snippets and he showed me one for enumerating Exchange Servers in Active Directory. I dug the code but wanted to try to see if I could use my Recordset/ADsDSOObject skrills to shorten the code. The outcome isn't any shorter but it does get the version, so that's cool. Thanks, Sharfa, for pointing me towards the WMI Exchange_Server thing, too. 
'****************************************************************************
' This script created by Chrissy LeMaire (clemaire@gmail.com)
' Website: http://netnerds.net/
'
' This script finds all Exchange Servers in AD. Includes Exchange Version.
'
' Run this script with admin privs on any computer within a domain.
'
' This script has only been tested on Windows Server 2003
'
' NO WARRANTIES, USE THIS AT YOUR OWN RISK, etc.
'*****************************************************************************
Set objAdRootDSE = GetObject("LDAP://RootDSE")
Set objRS = CreateObject("adodb.recordset")
varConfigNC = objAdRootDSE.Get("configurationNamingContext")
strConnstring = "Provider=ADsDSOObject"
strSQL = "SELECT * FROM 'LDAP://" & varConfigNC & "' WHERE objectCategory='msExchExchangeServer'"
objRS.Open strSQL, strConnstring
Do until objRS.eof
Set objServer = GetObject(objRS.Fields.Item(0))
Call getExchangeInfo(objServer.CN)
Set objServer = Nothing
objRS.movenext
Loop
objRS.close
Set objRS = Nothing
Set objAdRootDSE = Nothing
Sub getExchangeInfo(strServerName)
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!" & strServerName & "\\ROOT\MicrosoftExchangeV2")
Set colItems = objWMIService.ExecQuery("Select * from Exchange_Server")
For Each objItem in colItems
MsgBox UCase(objItem.Name) & " (" & objItem.FQDN & ") is running Exchange " & objItem.ExchangeVersion
Next
Set colItems = Nothing
Set objWMIService = Nothing
End SubVBScript: Windows XP/IIS 5.1 DOES Support Denying Access by IP Addresses
In helping a visitor to troubleshoot running my IIS FTP ban script, I realized that while XP makes it appear as though it doesn't support banning users by IP address, it actually does provide that support; you just have to ban the IPs programatically.
Here, you can see that the IP address and domain name restrictions section is greyed out. However, you can use the following VBScript to enable and ban users in IIS' Default Web SIte. The first script listed does the following:
1. Ensures that AllowByDefault is set to true (which is the default anyway)
2. Bans a few example IP addresses
3. Confirms the addresses were successfully banned
strComputer = "localhost"
arrBanTheseIPs = Array("10.0.0.200","42.42.42.42")
'Set Objects
Set objWebSite = GetObject("IIS://" & strComputer & "/W3SVC/1")
Set objIPRestrict = objWebSite.IPSecurity
objIPRestrict.GrantByDefault = True
objIPRestrict.IPDeny = arrBanTheseIPs
objWebSite.IPSecurity = objIPRestrict
objWebSite.SetInfo
WScript.Echo "The following IP addresses are now banned:"
arrDeniedIPs = objIPRestrict.IPDeny
for i = 0 to Ubound(arrDeniedIPs)
WScript.Echo arrDeniedIPs(i)
next
'Kill Objects
Set objIPRestrict = Nothing
Set objWebSite = NothingTo Delete All Previously Banned IPs, you would use the following code which overwrites all the IPs with one invalid IP.
strComputer = "localhost"
'Set Objects
Set objWebSite = GetObject("IIS://" & strComputer & "/W3SVC/1")
Set objIPRestrict = objWebSite.IPSecurity
objIPRestrict.GrantByDefault = True
objIPRestrict.IPDeny = Array("0.0.0.0")
objWebSite.IPSecurity = objIPRestrict
objWebSite.SetInfo
'Kill Objects
Set objIPRestrict = Nothing
Set objWebSite = NothingIf you find yourself needing to unban a single IP address, you can use the following code which gathers all the banned IPs except the one you want to delete and rebans them (IPDeny requires a full list each time you set it).
strComputer = "localhost"
'Set Objects
Set objWebSite = GetObject("IIS://" & strComputer & "/W3SVC/1")
Set objIPRestrict = objWebSite.IPSecurity
strUnbanSingleIP = "10.0.0.200"
arrIPAddresses = objIPRestrict.IPDeny
For i = 0 to ubound(arrIPAddresses)
strClientIP = Left(arrIPAddresses(i),InStr(arrIPAddresses(i),",")-1)
If strClientIP <> strUnbanSingleIP Then
If Len(strStillBanned) = 0 Then
strStillBanned = strClientIP
Else
strStillBanned = strStillBanned & "," & strClientIP
End If
End If
Next
If Len(strStillBanned) = 0 Then strStillBanned = "0.0.0.0" 'just in case it was the only one
arrStillBannedIPs = split(strStillBanned,",")
objIPRestrict.IPDeny = arrStillBannedIPs
objWebSite.IPSecurity = objIPRestrict
objWebSite.SetInfo
'Kill Objects
Set objIPRestrict = Nothing
Set objWebSite = NothingIf your script is successful, banned users will see the following message:
You are not authorized to view this pageHTTP 403.6 - Forbidden: IP address rejected
To show all of the current IPs which have been banned, run the following script
strComputer = "localhost"
'Set Objects
Set objWebSite = GetObject("IIS://" & strComputer & "/W3SVC/1")
Set objIPRestrict = objWebSite.IPSecurity
arrDeny = objWebSite.Get("IPSecurity").IPDeny
For i = 0 to Ubound(arrDeny)
strBannedIPs = strBannedIPs & arrDeny(i) & vbCrlf
Next
If len(strBannedIPs) > 0 Then
msgbox "IP, Subnet: " & vbCrLF & strBannedIPs
Else
msgbox "No IPs have been banned."
End if
'Kill Objects
Set objIPRestrict = Nothing
Set objWebSite = NothingWhile I haven't tested it, the same scripts should work if you want to deny all IPs except those explicitly listed. To do so, simply set objIPRestrict.GrantByDefault to False and replace the above mentions of IPDeny with IPGrant. Same goes for MSFTPSVC -- if you want to modify the FTP service settings, just change the above instances of "W3SVC" to "MSFTPSVC".
VBScript: Kerberos, Delegation, IIS and User Authentication
Recently, I wanted to write a web-based front end to AD User Management for our help desk. The way that I set it up apparently broke some Kerberos delegation rules and even though Microsoft wrote a step-by-step guide on how to get IIS and Kerberos delegation going, the solution didn't work for me. If I turned off Anonymous access and authenticated as myself against a remote webserver (local webserver totally worked), I would get the error 0x80040E37 - Table Does Not Exist. The table does exist, of course, I just don't have the rights to see it. Well, I do but not in the "double hop" manner that I'm attempting it. Kerberos sees that IIS != me.. IIS is only pretending to be me and it doesn't approve.
After a few days of tinkering, this is the solution I decided on. I set the ASP page in IIS to Anonymous Access but ran that access as a user with the privleges to make changes to user accounts. This can be dangerous in more than one way -- if a lesser-privleged user were to somehow have the ability to edit that page, he or she could use it to run any script under the power of that user. So I ensured that unauthorized users were not able to access that file. But now how can I detect who's running that page? Request.servervariables("REMOTE_USER") would be useless since the page is running as that privleged user. I considered what client variables I did have access to and realized that request.servervariables("REMOTE_HOST") would be the handiest. I figured that, using WMI and the IP address, it would be possible to figure out what user is actively logged into the client machine. Sure enough...
Function getLoggedInUser(ipaddr)
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!"& ipaddr & "\root\cimv2")
Set colSessions = objWMIService.ExecQuery("Select * from Win32_LogonSession Where LogonType = 2 OR LogonType = 10" )
For Each objSession in colSessions
Set colList = objWMIService.ExecQuery("Associators of {Win32_LogonSession.LogonId=" & objSession.LogonId & "} Where AssocClass=Win32_LoggedOnUser Role=Dependent")
For Each objItem in colList
getLoggedInUser = lcase(objItem.Name)
Next
Next
End FunctionThis script, which was derived from a tek-tips.com post, worked flawlessly! FWIT, LoginType 2 is console and 10 is remote desktop.
VBScript: Output Snippet
This function can be found on Microsoft.com somewhere. I remember once finding some nslookup function where the author wrote the output of nslookup to a file on the hard drive, parsed it then forgot to delete it. I used that script and after a few years, I found that directory full of thousands of text files. Anyway, using StdOut.ReadAll would have been much more efficient. Here's a snippet I've used over and over:
Function PingHost(strComputer)
Set objShell = CreateObject("WScript.Shell")
Set objExec = objShell.Exec("ping -n 2 -w 1000 " & strComputer)
strPingResults = LCase(objExec.StdOut.ReadAll)
If InStr(strPingResults, "reply from") Then
PingHost = True
Else
PingHost = False
End If
Set objExec = Nothing
Set objShell = Nothing
End FunctionFor the record, a better way to find out if a machine is pingable is by using WMI and the machine's fully qualified domain name (if you use the netbios name, there is a delay if the host doesn't exist..but DNS reports back immediately)
Set objWMIService = GetObject("winmgmts:\.\root\cimv2")
strComputer = "myServer.myDomain.net"
Set colItems = objWMIService.ExecQuery("Select * from Win32_PingStatus Where Address = '" & strComputer & "'")
For Each objItem in colItems
If objItem.StatusCode = 0 Then 'The Computer is Pingable
msgbox "Woot"
End if
Next
Set objWMIService = NothingAD: Quickly Determine OU of User using VBScript
I'm working on a few Active Directory scripts that require knowing the full path or "distinguished name" of the user object. All I know initially is the username and domain name and I found a script at Hey, Scripting Guy! that is really useful -- it searches AD for the user's OU information. The only problem I had with the script is that it was properly done and thus, really long. At 26 lines, give or take, it cluttered my code so I decided to cut it down drastically. It's likely that my code isn't efficient and will probably take down the server one day but whatever, it sure is teeny!
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = _
"SELECT distinguishedName FROM 'LDAP://dc=fabrikam,dc=com' “ & _
"WHERE objectCategory='user' " & _
"AND sAMAccountName='kenmyer'"
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
strDN = objRecordSet.Fields("distinguishedName").Value
arrPath = Split(strDN, ",")
intLength = Len(arrPath(1))
intNameLength = intLength - 3
Wscript.Echo Right(arrPath(1), intNameLength)
objRecordSet.MoveNext
LoopShortened down to 7 lines and 1 object
Set rs = CreateObject("adodb.recordset")
Connstring = "Provider=ADsDSOObject"
strSQL = "SELECT distinguishedName FROM 'LDAP://dc=fabrikam,dc=com' WHERE objectCategory='user' AND sAMAccountName='kenmyer'"
rs.Open strSQL, Connstring
if not rs.eof and not rs.bof Then fullPath = rs("distinguishedName")
rs.close
Set rs = NothingVBScript: Stop Dictionary FTP Attacks in IIS using VBScript
Spencer Ruport of netortech.com modified my FTP ban script into one that stops dictionary attacks. And he chooses not to ban via the problematic IIS way but instead creating a bad route for the offending IP address. Pretty darn ingenius.
Set objFTPSVC = GetObject("IIS://localhost/MSFTPSVC")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = CreateObject("MSWC.IISLog")
Set objDictionary = CreateObject("Scripting.Dictionary")
Dim Attempts(), IP(), LastAttempt(), IPs
Dim AlreadyBanned, InProcess, Session
Dim CutOff, x, i
IPs = 0
'Iterate through each FTP site.
For Each objSITE in objFTPSVC
If lcase(objSITE.class) = "iisftpserver" Then
ftpLogFilePath = objSITE.LogFileDirectory & "\msftpsvc" & objSITE.Name
Set objFolder = objFSO.GetFolder(ftpLogFilePath)
Set objFiles = objFolder.Files
For Each fileName In objFiles
lastFile = fileName
Next
strLogFile = lastFile
Set file = Nothing
Set objFolder = Nothing
'Use the IIS log file parser provided by MSFT
objLog.OpenLogFile strLogFile, 1, "MSFTPSVC", 1, 0
'(FileName,IOMode,ServiceName,ServiceInstance,OutputLogFileFormat)
' 0 = NotApplicable, 1 = ForReading
Do While NOT objLog.AtEndOfLog
objLog.ReadLogRecord
If instr(ucase(objLog.Method), "USER") Then
'Someone is attempting to authenticate with the FTP server
InProcess = False
AlreadyBanned = False
For x = 0 to IPs - 1
'Check to see if this IP address has already attempted to log in.
If objLog.ClientIP = IP(x) Then
'To be nice this code will give the user
'another attempt every minute.
'This is to avoid banning a person who
'attempts to log in multiple times
'in a day but keeps forgetting their password.
Attempts(x) = Attempts(x) + datediff("n", objLog.DateTime, lastattempt(x))
LastAttempt(x) = objLog.DateTime
InProcess = True
End If
Next
If Not InProcess Then
'If we aren't keeping track of this IP
'it's possible the IP has already been
'added to the ban list.
AlreadyBanned = objDictionary.Exists(objLog.ClientIP)
End If
If Not InProcess And Not AlreadyBanned Then
'First authentication attempt by this IP
IPs = IPs + 1
Redim Preserve IP(IPs)
Redim Preserve Attempts(IPs)
Redim Preserve LastAttempt(IPs)
IP(IPs - 1) = objLog.ClientIP
Attempts(IPs - 1) = 1
LastAttempt(IPs - 1) = objLog.DateTime
End If
ElseIf instr(ucase(objLog.Method), "PASS") Then
'The server is responding to an authentication
'attempt.
For x = 0 to IPs - 1
'See if we're keeping track of this IP
If IP(x) = objLog.ClientIP Then
'Increment the authentication attempts
Attempts(x) = Attempts(x) + 1
If Attempts(x) = 10 Then
'Ban if necessary
WScript.Echo "Banning " & objLog.ClientIP & "..."
objDictionary.Add objLog.ClientIP, "255.255.255.255"
AddDeadRoute objLog.ClientIP
For i = x to (IPs - 2)
IP(i) = IP(i + 1)
Attempts(i) = Attempts(i + 1)
Next
IPs = IPs - 1
Redim Preserve IP(IPs)
Redim Preserve Attempts(IPs)
End If
End If
Next
End If
Loop
objLog.CloseLogFiles 1
End If
Next
Set objDictionary = Nothing
Set objLog = Nothing
Set objFSO = Nothing
Set objFTPSVC = Nothing
Function addDeadRoute(IP)
dim adoDBConn, sConnStr, objFSO, objBanBatch, cmdShell, WshShell
Dim fakeGateway
'I've been told that IPSec could be used to block certain IPs
'but 1) I'm not sure WMI can interface with it and 2) I don't
'know how to begin with. Someone gave me a much easier solution
'Simply add a route to the routing table pointing to a gateway
'that doesn't exist.
'Ensure that this IP is on the same subnet as the server
fakeGateway = "192.168.1.101"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objBanBatch = objFSO.CreateTextFile("W:\config files\blocks\addRoute.bat", True)
objBanBatch.WriteLine "ROUTE ADD " & IP & " MASK 255.255.255.255 " & fakeGateWay
objBanBatch.Close
WshShell.Run """W:\config files\blocks\addRoute.bat""", 1, True
Set objFSO = Nothing
End FunctionAbout
-
We are IT consultants
who grew up living and loving life
in Cajun Country.
Authors
Categories
