Function BeautifyVBS (sSource, nTabSpacing)
' Takes VBScript source code and rebuilds the indentation.
Dim sRawLine, sLine, sTest, iIndentIndex, iIndex, oS, sWhiteSpace, bAdjustIndent, bInQuote, aRows
 
Dim aKey(34)
 
Const INDENT_String = 0
Const INDENT_Exeception_String = 1
Const INDENT_Pre_Indent = 2
Const INDENT_Post_Indent = 3
 
' The indent and unindent list is as complete as I could make it (from the MS VBScript reference).
aKey (0) = ARRAY ("if ", " then", 0, 1)
aKey (1) = ARRAY ("select ", "", 0, 2)
aKey (2) = ARRAY ("sub ", "", 0, 1)
aKey (3) = ARRAY ("function ", "", 0, 1)
aKey (4) = ARRAY ("do ","", 0, 1)
aKey (5) = ARRAY ("while ","", 0, 1)
aKey (6) = ARRAY ("for ","", 0, 1)
aKey (7) = ARRAY ("case ", "", -1, 1)
aKey (8) = ARRAY ("with ","", 0, 1)
aKey (9) = ARRAY ("class ","", 0, 1)
aKey (10) = ARRAY ("public sub","", 0, 1)
aKey (11) = ARRAY ("private sub ","", 0, 1)
aKey (12) = ARRAY ("public function ","", 0, 1)
aKey (13) = ARRAY ("private function ","", 0, 1)
aKey (14) = ARRAY ("property get ","", 0, 1)
aKey (15) = ARRAY ("public property get ","", 0, 1)
aKey (16) = ARRAY ("private property get ","", 0, 1)
aKey (17) = ARRAY ("property let ","", 0, 1)
aKey (18) = ARRAY ("public property let ","", 0, 1)
aKey (19) = ARRAY ("private property let ","", 0, 1)
aKey (20) = ARRAY ("property set ","", 0, 1)
aKey (21) = ARRAY ("public property set ","", 0, 1)
aKey (22) = ARRAY ("private property set ","", 0, 1)
aKey (23) = ARRAY ("else ","", -1, 1)
aKey (24) = ARRAY ("elseif ","", -1, 1)
aKey (25) = ARRAY ("end if", "", -1, 0)
aKey (26) = ARRAY ("end select", "", -2, 0)
aKey (27) = ARRAY ("end sub", "", -1, 0)
aKey (28) = ARRAY ("end function", "", -1, 0)
aKey (29) = ARRAY ("loop", "", -1, 0)
aKey (30) = ARRAY ("wend", "", -1, 0)
aKey (31) = ARRAY ("next", "", -1, 0)
aKey (32) = ARRAY ("end class", "", -1, 0)
aKey (33) = ARRAY ("end property", "", -1, 0)
aKey (34) = ARRAY ("end with", "", -1, 0)
 
sWhiteSpace = " " & vbTab
 
Set oS = CreateObject("ADODB.Stream")
oS.Type = 2   ' ASCII
oS.Open
 
iIndentIndex = 0
For Each sRawLine in Split (sSource, vbCrLf)
 
' Remove all whitespace on the left
iIndex = 1
If Len (sRawLine) > 0 Then
Do While iIndex <= Len (sRawLine)
If Instr (sWhiteSpace, Mid (sRawLine, iIndex, 1)) = 0 Then
Exit Do
End If
iIndex = iIndex + 1
Loop
End If
If iIndex > Len (sRawLine) Then
sLine = ""
Else
sLine = Mid (sRawLine, iIndex)
End If
 
' Remove all whitespace on the right
iIndex = Len (sLine)
Do While iIndex > 0
If Instr (sWhiteSpace, Mid (sLine, iIndex, 1)) = 0 Then
Exit Do
End If
iIndex = iIndex - 1
Loop
If iIndex < Len (sLine) Then
sLine = Left (sLine, iIndex)
End If
 
sTest = LCase (LTrim (sLine))
' Find any in-line comment marker, and truncate the comment if it exists.
bInQuote = False
For iIndex = 1 To Len (sTest)
If Not bInQuote And Mid (sTest, iIndex, 1) = "'" Then
Exit For
End If
If Mid (sTest, iIndex, 1) = """" Then
bInQuote = Not bInQuote
End If
Next
If iIndex < Len (sTest) Then  ' Truncate comment
sTest = Left (sTest, iIndex - 1)
' Truncate whitespace again
iIndex = Len (sTest)
Do While iIndex > 0
If Instr (sWhiteSpace, Mid (sTest, iIndex, 1)) = 0 Then
Exit Do
End If
iIndex = iIndex - 1
Loop
If iIndex < Len (sTest) Then
sTest = Left (sTest, iIndex)
End If
End If
 
sTest = LCase (LTrim (sTest)) & SPACE (32)
 
' Adjust Indentation as needed
bAdjustIndent = False
For iIndex = 0 To UBound (aKey, 1)
If Left (sTest, LEN (aKey(iIndex)(INDENT_String))) = aKey(iIndex)(INDENT_String) Then
If LEN(aKey(iIndex)(INDENT_Exeception_String)) = 0 Or Right (RTrim (sTest), LEN (aKey(iIndex)(INDENT_Exeception_String))) = aKey(iIndex)(INDENT_Exeception_String) Then
bAdjustIndent = True
Exit For
End If
End If
Next
 
If bAdjustIndent Then
iIndentIndex = iIndentIndex + aKey(iIndex)(INDENT_Pre_Indent)
If iIndentIndex < 0 Then iIndentIndex = 0
End If
 
If nTabSpacing <= 0 Then
oS.WriteText STRING (iIndentIndex, vbTab) & sLine & vbCrLf
Else
oS.WriteText SPACE (nTabSpacing * iIndentIndex) & sLine & vbCrLf
End If
 
If bAdjustIndent Then
iIndentIndex = iIndentIndex + aKey(iIndex)(INDENT_Post_Indent)
If iIndentIndex < 0 Then iIndentIndex = 0
End If
Next
 
oS.Position = 0
BeautifyVBS = oS.ReadText (-1)
oS.Close()
Set oS = Nothing
End Function

' Touch.vbs -- Take 1 or more files, and changes the last modified date to the current time.
' John J Schultz -- Public Domain.
'
' Parameters
'   wscript //NOLOGO //B TouchFiles.vbs {file1} [{file3} [...]]
'
' ----------------------------
 
Option Explicit
 
Dim aFiles, oShell, oFS, oFolder, oArgs, iCount, bValidParameters, sLine, dTimestamp
 
set oShell = WScript.CreateObject("WScript.Shell")
sLine = ""
on error resume next
sLine = oShell.RegRead ("HKCR\*\shell\Touch\")
on error goto 0
If sLine = "" Then
	oShell.RegWrite "HKCR\*\shell\Touch\", "Touch", "REG_SZ"
	oShell.RegWrite "HKCR\*\shell\Touch\command\", "wscript.exe """ & WScript.ScriptFullName & """ ""%1""", "REG_SZ"
	MsgBox "You can now touch any file from the context menu in Windows Explorer, by right-clicking on the file and selecting Touch", vbOKonly + vbInformation, "Shell extension installed."
	Set oShell = Nothing
	WScript.Quit (0)
End If
Set oShell = Nothing
 
Set oArgs = WScript.Arguments
bValidParameters = (oArgs.Count >= 1)
If bValidParameters Then
	For iCount = 0 to oArgs.Count - 1
		If iCount = 0 Then
			ReDim aFiles (iCount)
		Else
			ReDim Preserve aFiles (iCount)
		End If
		aFiles (iCount) = oArgs(iCount)
	Next
End If
Set oArgs = Nothing
 
If Not bValidParameters Then
	WScript.Echo "Invalid parameters"
	WScript.Quit(0)
End If
 
dTimeStamp = Now()
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("Shell.Application")
For iCount = 0 To UBound (aFiles, 1)
	If Not oFS.FileExists (aFiles (iCount)) Then
		WScript.Echo "Skipping missing file: " & aFiles (iCount)
	Else
		Set oFolder = oShell.NameSpace(oFS.GetParentFolderName (aFiles (iCount)))
		oFolder.Items.Item(oFS.GetFileName (aFiles (iCount))).ModifyDate = dTimeStamp
		Set oFolder = Nothing
	End If
Next ' File
Set oShell = Nothing
Set oFS = Nothing

' DeleteAgedFiles.vbs -- Remove files by any combination of timestamp aging, file pattern.
' John J Schultz -- 12/12/2005 -- Public Domain.
'
' //B is the switch recommended for production use with wscript to suppress operator messages from
' the script engine (e.g. when launched from a timer).  Due to the number of WScript.Echo statements used,
' Cscript is highly recommended--even when testing.
 
' ----------------------------
' Parameters
Dim bAggressive
Dim bTestRun
Dim bIncludeSubFolders
Dim bSpareRootFolder
Dim bRemoveEmptyFolders
Dim bBatchMode
Dim bUserConfirmationForDelete
Dim bIgnoreZeroLengthFiles
Dim nDateToCheck
Dim nDays
Dim sStartFolder
Dim sFilePattern
Dim nPreserveFileCount
 
' ----------------------------
' Global
Dim dCutOff
Dim iErr, sErr
 
' ###################################################################################
' Support Functions and Subs
Sub LogAnEvent (iType, sMessage)
	Set WshShell = WScript.CreateObject("WScript.Shell")
	WshShell.LogEvent iType, sMessage
	Set WshShell = Nothing
End Sub
 
Function DateToAnsi (dTime)
   DateToAnsi = _
   Year(dTime) & Right ("0" & Month (dTime), 2) & Right ("0" & Day (dTime), 2) & _
   Hour(dTime) & Right ("0" & Minute (dTime), 2) & Right ("0" & Second (dTime), 2)
End Function
 
Sub QuickSort(ByRef aKey, nLowBound, nHighBound)
	' Single dimension array only.
	Dim vPivot, nLowSwap, nHighSwap, vTemp
 
	If IsEmpty (nLowBound) Then
		nLowBound = LBound (aKey)
	End If
	If IsEmpty (nHighBound) Then
		nHighBound = UBound (aKey)
	End If
 
	' Two items to sort
	If nHighBound - nLowBound = 1 Then
		If aKey(nLowBound) > aKey(nHighBound) Then
			vTemp = aKey(nLowBound)
			aKey(nLowBound) = aKey(nHighBound)
			aKey(nHighBound) = vTemp
		End If
	End If
 
	' Three or more items to sort
 
	vPivot = aKey(int((nLowBound + nHighBound) / 2))
	aKey(int((nLowBound + nHighBound) / 2)) = aKey(nLowBound)
	aKey(nLowBound) = vPivot
 
	nLowSwap = nLowBound + 1
	nHighSwap = nHighBound
 
	Do
		' Find the right nLowSwap
		While nLowSwap < nHighSwap and aKey(nLowSwap) <= vPivot
			nLowSwap = nLowSwap + 1
		Wend
		' Find the right nHighSwap
		While aKey(nHighSwap) > vPivot
			nHighSwap = nHighSwap - 1
		Wend
		' Swap values if out of sort order
		If nLowSwap < nHighSwap Then
			vTemp = aKey(nLowSwap)
			aKey(nLowSwap) = aKey(nHighSwap)
			aKey(nHighSwap) = vTemp
		End If
	Loop While nLowSwap < nHighSwap
 
	aKey(nLowBound) = aKey(nHighSwap)
	aKey(nHighSwap) = vPivot
 
	' Recursive call
	' 2 or more items in first section
	If nLowBound < (nHighSwap - 1) Then Call QuickSort(aKey, nLowBound, nHighSwap - 1)
	' 2 or more items in second section
	If nHighSwap + 1 < nHighBound Then Call QuickSort(aKey, nHighSwap + 1, nHighBound)
 
End Sub
 
Function FolderExists (sFolderName)
	Dim oFS
 
	Set oFS = CreateObject("Scripting.FileSystemObject")
	FolderExists = oFS.FolderExists(sFolderName)
	set oFS = Nothing
End Function
 
Function FileMatchesPattern (sFile, sPattern, bIgnoreCase)
    ' Returns true if the file name matches the regular expression in sPattern.
    Dim oRegEx
 
    Set oRegEx = New RegExp
    With oRegEx
	    .Pattern = sPattern
	    .IgnoreCase = bIgnoreCase
	    FileMatchesPattern = .Test (sFile)   ' Execute search.
    End With
    Set oRegEx = Nothing
End Function
 
Sub RemoveFilesInFolder (sPath, bAtTop)
	' Recursive -- uses modular variables
	Dim objFSO
	Dim objFolder
	Dim objFolders
	Dim objFile
	Dim objFiles
	Dim objItem
	Dim sFileName
	Dim bPardoned
	Dim sWorkPath
	Dim iErr
	Dim aSort
 
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	sWorkPath = sPath
	If Right (sWorkPath, 1) <> "\" Then sWorkPath = sWorkPath & "\"
 
	Set objFolder = objFSO.GetFolder(sPath)
 
	' First recurse to any sub-folders, and remove files from them.
	If bIncludeSubFolders Then
		For Each objItem In objFolder.SubFolders
			Call RemoveFilesInFolder (sWorkPath & objItem.Name, False)
		Next 'objItem
	End If
 
	WScript.Echo
	WScript.Echo "--- " & sPath
 
	' First, enumerate the files and delete them.
	If Not bAtTop Or Not bSpareRootFolder Then
		If objFolder.Files.Count - nPreserveFileCount > 0 Then
			ReDim aSort (objFolder.Files.Count - 1)
			nI = 0
			For Each objItem in objFolder.Files
				If nDateToCheck = 0 Then
					aSort (nI) = DateToAnsi (objItem.DateCreated) & "\" & objItem.Name
 
				ElseIf nDateToCheck = 1 Then
					aSort (nI) = DateToAnsi (objItem.DateLastModified) & "\" & objItem.Name
 
				ElseIf nDateToCheck = 2 Then
					aSort (nI) = DateToAnsi (objItem.DateLastAccessed) & "\" & objItem.Name
 
				End If
				nI = nI + 1
			Next
 
			Call QuickSort (aSort, Empty, Empty)
 
			For nI = 0 To UBound (aSort) - nPreserveFileCount
				sTmp = Split(aSort(nI), "\")(1)
				'WScript.Echo sTmp
				Set objFile = objFSO.GetFile (sWorkPath & sTmp)
 
				If Not FileMatchesPattern (objFile.Name, sFilePattern, True) Then
					bPardoned = True
					'WScript.Echo "Name does not match filter pattern: " & objFile.Name
 
				ElseIf bIgnoreZeroLengthFiles And objFile.Size = 0 Then
					bPardoned = True
					WScript.Echo "Ignoring null-length file: " & objFile.Name
 
				ElseIf Not bAggressive And (objFile.Attributes AND 7) <> 0 Then
					WScript.Echo "Attribute-protected file ignored: " & objFile.Name
					bPardoned = True
 
				ElseIf nDateToCheck = 0 And DateAdd ("d", 0, objFile.DateCreated) > dCutOff Then
					WScript.Echo "Young file kept: " & objFile.Name
					bPardoned = True
 
				ElseIf nDateToCheck = 1 And DateAdd ("d", 0, objFile.DateLastAccessed) > dCutOff Then
					WScript.Echo "Young file kept: " & objFile.Name
					bPardoned = True
 
				ElseIf nDateToCheck = 2 And DateAdd ("d", 0, objFile.DateLastModified > dCutOff) Then
					WScript.Echo "Young file kept: " & objFile.Name
					bPardoned = True
 
				ElseIf bTestRun Then
					WScript.Echo "Qualifies for deletion: " & objFile.Name
					bPardoned = True
 
				Else
					bPardoned = False
 
				End If
 
				If Not bPardoned Then
					Err.Clear
					sFileName = objFile.Name
					On Error Resume Next
					objFile.Delete
					iErr = Err.Number
					On Error Goto 0
					If iErr = 0 Then
						WScript.Echo "Deleted: " & objFile.Name
					Else
						WScript.Echo "Could not delete: " & objFile.Name
					End If
				End If
				Set objFile = Nothing
			Next ' File
		End If
	End If
 
	' Remove the folder if it is empty, and the option to remove empty folders has been selected.
	' NOTE: We don't delete the folder if any files are detected in it--protected or not.
	If (Not bAtTop Or bSpareRootFolder) And bRemoveEmptyFolders Then
 
		bPardoned = False
		For Each objItem In objFolder.Files
			bPardoned = True
			Exit For
		Next
		For Each objItem In objFolder.SubFolders
			bPardoned = True
			Exit For
		Next
 
		If Not bPardoned Then
			Err.Clear
			On Error Resume Next
			objFolder.Delete
			iErr = Err.Number
			On Error Goto 0
			If iErr = 0 Then
				WScript.Echo "Killed empty folder..."
			Else
				WScript.Echo "Empty folder survived (may contain hidden or system files)..."
			End If
		End If
	End If
 
	Set objItem = Nothing
	Set objFolder = Nothing
	Set objFSO = CreateObject("Scripting.FileSystemObject")
 
End Sub
 
Sub HandleError (iErr, sErr)
 
	If bBatchMode Then
		LogAnEvent 1, sMsg
	Else
		WScript.Echo sMsg
	End If
 
End Sub
 
Sub Usage ()
	WScript.Echo "DeleteOldFiles.vbs -- Remove files older than a specified number of days from one or more folders. "
	WScript.Echo "John J Schultz -- 12/12/2005 -- Public Domain. "
	WScript.Echo " "
	WScript.Echo "cscript DeleteOldFiles.vbs [{switches}] {days} folder [pattern]"
	WScript.Echo " "
	WScript.Echo "- Days is the age (in days) of the file's time stamp, to remove the file. Default: 30 days "
	WScript.Echo "- Folder is an existing folder containing the files targeted for removal. "
	WScript.Echo "- pattern is a regular expression used to filter matching file names targeted for removal. If not present, all files are included."
	WScript.Echo " "
	WScript.Echo "-------------------------- Available switches --------------------------- "
	WScript.Echo "/t   - test only (a.k.a. chicken run): shows files affected, but does not actually delete them."
	WScript.Echo "/a   - aggressive: attempts to remove read-only files. "
	WScript.Echo "/s   - recurse files in subdirectories. "
	WScript.Echo "/d   - remove a sub-directory if it is empty after removing files (does not include the initial folder). "
	WScript.Echo "/b   - run in batch mode (errors logged to NT Event Log) "
	WScript.Echo "/r   - spares files in the initial (root) folder.  Use with /s when only files in sub-folders "
	WScript.Echo "       should be removed.  If this switch is used without /s, it has no effect. "
	WScript.Echo "/0-  - ignores files with zero-length. "
	WScript.Echo "/d:c[reate]   - (default) uses creation date to measure age.  Note: Creation date on a copied "
	WScript.Echo "                file is the date it was copied (i.e.: it does not inherit the original file's "
	WScript.Echo "                creation date). "
	WScript.Echo "/d:a[ccess]   - uses last access date to measure age. "
	WScript.Echo "/d:m[odified] - uses last modified date to measure age. "
	WScript.Echo "/n:# - preserve a count of files. Leaves at least this number of the newest files in the folder."
	WScript.Echo "/l:n - Log to NT Event Log: n = chatter level: "
	WScript.Echo "       0 = single summary "
	WScript.Echo "       1 = start/completion "
	WScript.Echo "       2 = (1) and all failures "
	WScript.Echo "       3 = (2) and all successes "
	WScript.Echo "    NOTE: NT Event logging is performed if /b (batch mode) is specified, otherwise messages "
	WScript.Echo "          are directed to the console. "
	WScript.Echo "------------------------------------------------------------------------ "
	WScript.Echo " "
	WScript.Echo "//B is the switch recommended for production use with wscript to suppress operator messages from "
	WScript.Echo "the script engine (e.g. when launched from a timer).  Due to the number of WScript.Echo statements used, "
	WScript.Echo "CScript is highly recommended--even when testing. "
End Sub
 
' ###################################################################################
' MAIN
 
' Module
Dim oFSO
Dim oFolder
Dim oFile
Dim oArgs
Dim nArgCnt
Dim iCount
Dim sApp
Dim bValidParameters
Dim sTmp
Dim sMsg
 
sApp = "DeleteOldFiles.vbs"
 
bTestRun = False
bIncludeSubFolders = False
bRemoveEmptyFolders = False
bBenchmark = False
bUserConfirmationForDelete = False
bIgnoreZeroLengthFiles = False
bTestOnly = False
nDateToCheck = 2  ' Default to date modified.
nDays = -1
nPreserveFileCount = 0
sStartFolder = ""
sFilePattern = "[.]+"
 
bValidParameters = True
 
Set oArgs = WScript.Arguments
iCount = oArgs.Count
If iCount = 0 Then
	bValidParameters = False
End If
 
If bValidParameters Then
	For iCount = 0 to oArgs.Count - 1
		sTmp = LCase (LTrim (RTrim (oArgs(iCount))))
		If Left (sTmp, 1) = "/" Then
 
			If sTmp = "/a" Then
				bAggressive = True
 
			ElseIf sTmp = "/t" Then
				bTestRun = True
 
			ElseIf sTmp = "/s" Then
				bIncludeSubFolders = True
 
			ElseIf sTmp = "/r" Then
				bSpareRootFolder = True
 
			ElseIf sTmp = "/d" Then
				bRemoveEmptyFolders = True
 
			ElseIf sTmp = "/b" Then
				bBatchMode = False
 
			ElseIf sTmp = "/q" Then
				bUserConfirmationForDelete = True
 
			ElseIf sTmp = "/0-" Then
				bIgnoreZeroLengthFiles = True
 
			ElseIf Left (sTmp & Space (4), 4) = "/d:c" Then
				nDateToCheck = 0
 
			ElseIf Left (sTmp & Space (4), 4) = "/d:a" Then
				nDateToCheck = 1
 
			ElseIf Left (sTmp & Space (4), 4) = "/d:m" Then
				nDateToCheck = 2
 
			ElseIf Left (sTmp & Space (3), 3) = "/n:" Then
				nPreserveFileCount = Int (Mid (sTmp & Space (4), 4))
				If nPreserveFileCount < 0 Then
					WScript.Echo "Invalid preserve count: " & nPreserveFileCount
					bValidParameters = False
				End If
 
			Else
				bValidParameters = False
				sMsg = "unrecognized switch: " & sTmp
 
			End If
 
		ElseIf nDays = -1 And Instr ("0123456789", Left (sTmp, 1)) > 0 Then
			on error resume next
			nDays = CInt (sTmp)
			on error goto 0
			If nDays < 0 Then
				bValidParameters = False
				sMsg = "day count must be >= 0: " & sTmp
			End If
 
		ElseIf sStartFolder = "" Then
			sStartFolder = LTrim (RTrim (oArgs(iCount)))
 
		ElseIf sFilePattern = "[.]+" Then
			sFilePattern = LTrim (RTrim (oArgs(iCount)))
 
		Else
			bValidParameters = False
			sMsg = _
			"Attempt to re-specify the folder: " & sTmp & vbCrLf & _
			"Already set as: " & sStartFolder
		End If
	Next
End If
 
Set objArgs = Nothing
 
If sStartFolder = "" Then
	sMsg = _
	"No starting folder specified"
	bValidParameters = False
End If
 
If Not bValidParameters Then
	If bBatchMode Then
		LogAnEvent 1, sMsg
	Else
		WScript.Echo sMsg
	End If
	Call Usage()
	WScript.Quit (1)
End If
 
If nDays < 0 Then nDays = 30
 
dCutOff = DateAdd ("d", -nDays, Now ())
 
WScript.Echo "Removing files older than " & nDays & " days (cutoff time: " & dCutoff & ")"
WScript.Echo "Expiration is evaluated on the " & Split ("creation|last access|last modification", "|")(nDateToCheck) & " timestamp."
 
' --- Processing starts here
Call RemoveFilesInFolder (sStartFolder, True)
 
WScript.Echo "Script completed"
 
WScript.Quit(0)

REM FtpBlocker.vbs
REM Launch once at system startup. Monitors the ftp activity for bad login attempts (Status Code 530).
REM If more than X failed login attempts are tried by a client, it's IP is added
REM to the routing table, with a fake gateway (dead IP) as the routing target. Designed to thwart
REM dictionary attacks.
REM This script works with Windows 2000 and later.
Dim aIpRoute, bShuttingDown
Function FileExists (sFileName)
	Dim oFSOSet oFSO = CreateObject("Scripting.FileSystemObject")
	FileExists = oFSO.FileExists(sFileName)
	set oFSO = Nothing
End Function
 
Sub DeleteFile (sFileName, bEvenIfReadOnly)
	Dim oFSO
 
	Set oFSO = CreateObject("Scripting.FileSystemObject")
	FileDelete = oFSO.DeleteFile(sFileName, bEvenIfReadOnly)
	set oFSO = Nothing
End Sub
 
Function FileToString (sFileName)
	Dim oFSO, oTS
	Set oFSO = CreateObject("Scripting.FileSystemObject")
	Set oTS = oFSO.OpenTextFile(sFileName, 1)
 
	FileToString = oTS.ReadAll
	oTS.Close()
 
	set oTS = Nothing
	set oFSO = Nothing
End Function
 
Sub StringToFile (sFileName, sText)
	Dim oFSO, oTS
	Set oFSO = CreateObject("Scripting.FileSystemObject")
	Set oTS = oFSO.OpenTextFile(sFileName, 2, True)
 
	oTS.Write sText
	oTS.Close()
 
	set oTS = Nothing
	set oFSO = Nothing
End Sub
 
Function RunOutput(cProgram, nWindowType)
	REM -- Obtain a Temporary File Name
	Dim oFS
	Set oFS = CreateObject("Scripting.FileSystemObject")
	Dim cFile
	cFile = oFS.GetSpecialFolder(2).Path & "\" & oFS.GetTempName
 
	REM -- Execute the command and redirect the output to the file
	Dim oShell
	Set oShell = CreateObject( "WScript.Shell" )
	oShell.Run cProgram & " >" & cFile, nWindowType, True
	Set oShell = Nothing
 
	REM -- Read output file and return
	Dim oFile
	Set oFile = oFS.OpenTextFile(cFile, 1, True)
	RunOutput = oFile.ReadAll()
	oFile.Close
 
	REM -- Delete Temporary File
	oFS.DeleteFile cFile
	Set oFS = Nothing
End Function
 
Function GetRoutingEntries()
	REM Capture the content of the current routing table.
	aRaw = Split (RunOutput("%COMSPEC% /C ROUTE PRINT", 0), vbCrLf)
 
	Set o = new RegExp
	o.Pattern = "((\d)+\.){3}(\d)+"
	o.Global = True
	o.MultiLine = False
	o.IgnoreCase = False
	aIP = Empty
	For Each s In aRaw
		Set oMatches = o.Execute (s)
		If oMatches.Count = 4 Then
			If IsArray (aIP) Then
				ReDim Preserve aIP (UBound (aIP, 1) + 1)
			Else
				ReDim aIP (0)
			End If
			aIP (UBound (aIP, 1)) = oMatches.Item(0) & "|" & oMatches.Item(2)
		End If
	Next
	GetRoutingEntries = aIP
End Function
 
REM -- Log the startup to the event log.
Set oWsh = WScript.CreateObject("WScript.Shell")
oWsh.LogEvent 0, "FtpBlocker530.vbs begins"
Set oWsh = WScript.CreateObject("WScript.Shell")
 
REM Load a snapshot of the IP's in the routing table, and use this as the baseline for determining
REM if the IP is in the list already.
 
aIpRoute = GetRoutingEntries()
bShuttingDown = False
 
REM Push Event Viewer Alert
Set objWMIService = GetObject("winmgmts:{(security)}!root/cimv2")
Set eventSink = wscript.CreateObject("WbemScripting.SWbemSink", "EVSINK100_")
strWQL = "Select * from __InstanceCreationEvent where TargetInstance isa 'Win32_NTLogEvent' and TargetInstance.SourceName = 'MSFTPSVC' and TargetInstance.EventCode = 100"
objWMIService.ExecNotificationQueryAsync eventSink,strWQL
 
Set objWMIService1 = GetObject("winmgmts:{(security)}!root/cimv2")
Set eventSink1 = wscript.CreateObject("WbemScripting.SWbemSink", "EVSINK6006_")
strWQL = "Select * from __InstanceCreationEvent where TargetInstance isa 'Win32_NTLogEvent' and TargetInstance.SourceName = 'eventlog' and TargetInstance.EventCode = 6006"
objWMIService.ExecNotificationQueryAsync eventSink1,strWQL
 
REM Create a flag file named FtpBlocker530.flg
REM When this file is not on the system, it is a signal to terminate this application.
 
StringToFile "FtpBlocker530.flg", "*** MARKER FILE ONLY ***"
 
REM Keep it going forever, or until the marker file is missing.
While (FileExists ("FtpBlocker530.flg") And Not bShuttingDown)
	Wscript.Sleep(1000)
Wend
 
If Not bShuttingDown Then
	Set oWsh = WScript.CreateObject("WScript.Shell")
	oWsh.LogEvent 0, "FtpBlocker530.vbs stopped by file removal"
	Set oWsh = Nothing
Else
	DeleteFile "FtpBlocker530.flg", True
End If
Set eventSink = Nothing
Set eventSink1 = Nothing
Set objWMIService = Nothing
Set objWMIService1 = Nothing
 
Sub EVSINK6006_OnObjectReady(objObject, objAsyncContext)
	bShuttingDown = True
End Sub
 
Sub EVSINK100_OnObjectReady(objObject, objAsyncContext)
 
	Set objDictionary = CreateObject("Scripting.Dictionary")
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	Set objLog = CreateObject("MSWC.IISLog")
	Set WshShell = WScript.CreateObject("WScript.Shell")
 
	fakeGateWayIP = "192.168.1.200" 'This is a black hole location on your subnet to route the packets.
	xMax = 5 'Max number of invalid login attempts
	xLogFiles = 10 'Max number of log files to keep in the folder before deleting them
 
	Set objFolder = objFSO.GetFolder(objFSO.GetSpecialFolder(0).Path & "\system32\LogFiles\MSFTPSVC1\")
	Set objFiles = objFolder.Files
	For Each fileName In objFiles
		lastFile = fileName
		Set f = objFSO.GetFile(fileName)
		If f.DateCreated <= Date - xLogFiles Then objFSO.DeleteFile FileName, True
		Set f = Nothing
	Next
	Set objFiles = Nothing
	Set objFolder = Nothing
 
	objLog.OpenLogFile lastFile, 1, "MSFTPSVC", 1, 0
	While NOT objLog.AtEndOfLog
		objLog.ReadLogRecord
		clientIP = trim(objLog.ClientIP)
		xStatus = trim(objLog.ProtocolStatus)
		If xStatus = "530" AND NOT (clientIP = fakeGateWayIP) then
			If objDictionary.Exists(ClientIP) Then
				objDictionary.Item(clientIP) = cStr(Clng(objDictionary.Item(clientIP)) + 1)
			Else
				objDictionary.Add clientIP,"1"
			End If
		End If
	Wend
	objLog.CloseLogFiles 1
 
	xChange = False
	For Each xClient in objDictionary.Keys
		xTest = False
		If Clng(objDictionary.Item(xClient)) < xMax then
			objDictionary.Remove(xClient)
		Else
			xTest = Not IsArray (aIpRoute)
			If Not xTest Then
				xTest = True
				For Each ip In aIpRoute
					If Split (ip, "|")(0) = xClient And Split (ip, "|")(1) = fakeGateWayIP Then
						xTest = False ' Client already exists in the routing table with the fakeGateWayIP as the gateway
						Exit For
					End If
				Next
			End If
			If xTest Then
				xChange = True
				WshShell.Run "%COMSPEC% /C ROUTE ADD " & xClient & " MASK 255.255.255.255 " & fakeGateWayIP, 0, True
				WshShell.LogEvent 1, "BAD ROUTE(s) assigned: FTP max of " & xMax & " occurrences for 530 Event(s) exceeded for " & xClient
			End If
		End If
	Next
 
	Set WshShell = Nothing
	Set objLog = Nothing
	Set objFSO = Nothing
	Set objDictionary = Nothing
 
	If xChange Then
		aIpRoute = GetRoutingEntries()
	End If
End Sub