Option Explicit
On Error Resume Next
' Deletes old files based on age, access date, extension.
' Written by Eric Phelps 
' http://www.ericphelps.com

'Force "cscript"
Main
Wscript.Quit 0

Sub Main()
Dim fil 'As Scripting.File
Dim fils 'As Scripting.Files
Dim fol 'As Scripting.Folder
Dim fols 'As Scripting.Folders
Dim fs 'As Scripting.FileSystemObject
Dim strDirectories() 'As String
Dim lngCounter 'As Long
Dim dblMaxCreateAge 'As Double
Dim dblMaxAccessedAge 'As Double
Dim strFileTypes 'As String
Const READONLY = 1
Const HIDDEN = 2
Const SYSTEM = 4
	If MsgBox ("This program will delete files in and below a directory you designate based on file age and extension. Continue?", vbOkCancel) = vbCancel Then Wscript.Quit
	Set fs = CreateObject("Scripting.FileSystemObject")
	If Lcase(Right(Wscript.FullName, 11)) = "wscript.exe" Then 
		If MsgBox ("This program is being run under WSCRIPT. Results will be stored in a log at " & FileNameInThisDir("DeleteOld.log") & ". Run this program under CSCRIPT if you want a real-time display of activity. Otherwise, a message box will pop up to inform you when the program finishes. Continue?", vbOkCancel, "Delete Old Files") = vbCancel Then Wscript.Quit
	Else
		If MsgBox ("This program is being run under CSCRIPT. Results will be displayed on-screen and will not be logged. Run this program under WSCRIPT if you want a log file. Continue?", vbOkCancel, "Delete Old Files") = vbCancel Then Wscript.Quit
	End If
	Redim strDirectories(0)
	strDirectories(0) = fs.GetAbsolutePathName(InputBox("Enter path to start deleting at:", "Delete Old Files", FileNameInThisDir("")))
	If strDirectories(0) = "" Then Wscript.Quit
	strFileTypes = InputBox("Enter dotted extensions for file types you DON'T want deleted", "Delete Old Files", ".txt .doc .xls .ppt .gif .jpg")
	If strFileTypes = "" Then Wscript.Quit
	dblMaxCreateAge = CDbl(InputBox("Enter the minimum time since file creation (in days) of files to delete", "Delete Old Files", "180"))
	If dblMaxCreateAge < 1 Then Wscript.Quit
	If MsgBox("This is your last question. File deletion starts if you click yes. Okay to delete everything except " & strFileTypes & " files in and below the " & strDirectories(0) & " directory created over " & dblMaxCreateAge & " days ago?", vbYesNo, "Delete Old Files") = vbNo Then Wscript.Quit
	lngCounter = 0
	Status "*************************************"
	Status "*************************************"
	Status "Program: " & Wscript.ScriptFullName
	Status "Program started: " & Now
	Status "Deleting all except " & strFileTypes & " in and below " & strDirectories(0) & " older than " & dblMaxCreateAge & " days"
	Do Until lngCounter > Ubound(strDirectories,1)
		'Next folder to process
		Set fol = fs.GetFolder(strDirectories(lngCounter))
		'Get each file in turn
		Set fils = fol.Files
		If Err.Number <> 0 Then Exit Sub
		For Each fil In fils
			If Instr(Lcase(strFileTypes), Lcase(Mid(fil.Name,InStrRev(fil.Name, ".")))) = 0 Then
			If (CDbl(Now) - CDbl(fil.DateCreated)) > dblMaxCreateAge Then
			If ((fil.Attributes And READONLY) = 0) Then
			If ((fil.Attributes And SYSTEM) = 0) Then
			If ((fil.Attributes And HIDDEN) = 0) Then
			If Lcase(fil.Path) <> Lcase(Wscript.ScriptFullName) Then
				Status fil.Path
				Status "	DELETED"
				Status "	Date Created " & fil.DateCreated
				Status "	Date Modified " & fil.DateLastModified
				fil.Delete
			End If
			End If
			End If
			End If
			End If
			End If
		Next
		'Check for any sub folders and add them to the folder array
		Set fols = fol.SubFolders
		For each fol in fols
			If Lcase(fol.Name) <> "recycled" Then
				Redim Preserve strDirectories(Ubound(strDirectories,1) + 1)
				strDirectories(Ubound(strDirectories,1)) = fol.Path
			End If
		Next
		lngCounter = lngCounter + 1
	Loop
	Status "Program finished: " & Now
	Status "*************************************"
	Status "*************************************"
	If Lcase(Right(Wscript.FullName, 11)) = "wscript.exe" Then MsgBox "Program Finished! Details are in the log at " & FileNameInThisDir("DeleteOld.log"), vbOkOnly, "Delete Old Files"
End Sub

Function FileNameInThisDir(strFileName) 'As String
'Returns the complete path and file name to a file in
'the script directory. For example, "trans.log" might
'return "C:\Program Files\Scripts\Database\trans.log"
'if the script was in the "C:\Program Files\Scripts\Database"
'directory.
Dim fs 'As Scripting.FileSystemObject
	Set fs = CreateObject("Scripting.FileSystemObject")
	 FileNameInThisDir = fs.GetAbsolutePathName(fs.BuildPath(Wscript.ScriptFullName, "..\" & strFileName))
	''''''''''Clean up
	Set fs = Nothing
End Function

Sub Status (strMessage)
'If the program was run with CSCRIPT, this writes a
'line into the DOS box. If run with WSCRIPT, it writes
'to a log named "DeleteOld.log" in the same directory as 
'the script.
Dim ts 'As Scripting.TextStream
Dim fs 'As Scripting.FileSystemObject
Const ForAppending = 8 'Scripting.IOMode
	If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then 
		Wscript.Echo strMessage
	Else
		Set fs = CreateObject("Scripting.FileSystemObject")
		Set ts = fs.OpenTextFile(FileNameInThisDir("DeleteOld.log"), ForAppending, True)
		ts.WriteLine strMessage
		ts.Close
		''''''''''Clean up
		Set ts = Nothing
		Set fs = Nothing
	End If
End Sub

Sub Force(sScriptEng)
'Forces this script to be run under the desired scripting host
'Valid sScriptEng arguments are "wscript" or "cscript"
'If you don't supply a valid name, Force will switch hosts...
	If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then
		'Running under WSCRIPT
		If Instr(1, Wscript.FullName, sScriptEng, 1) = 0 Then
			'Need to switch to CSCRIPT
			CreateObject("Wscript.Shell").Run "cscript.exe " & Wscript.ScriptFullName
			Wscript.Quit
		End If
	Else
		'Running under CSCRIPT
		If Instr(1, Wscript.FullName, sScriptEng, 1) = 0 Then
			'Need to switch to WSCRIPT
			CreateObject("Wscript.Shell").Run "wscript.exe " & Wscript.ScriptFullName
			Wscript.Quit
		End If
	End If
End Sub