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, extension, and last access. 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 3-character extensions for file types you 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
dblMaxAccessedAge = CDbl(InputBox("Enter the minimum time since last file access (in days) of files to delete", "Delete Old Files", "60")
If dblMaxAccessedAge < 1 Then Wscript.Quit
If MsgBox("This is your last question. File deletion starts if you click yes. Okay to delete all " & strFileTypes & " in and below the " & strDirectories(0) & " directory created over " & dblMaxCreateAge & " days ago and not accessed for the past " & dblMaxAccessedAge & " days?", vbYesNo, "Delete Old Files" = vbNo Then Wscript.Quit
lngCounter = 0
Status "*************************************"
Status "*************************************"
Status "Program: " & Wscript.ScriptFullName
Status "Program started: " & Now
Status "Deleting " & strFileTypes & " in and below " & strDirectories(0) & " older than " & dblMaxCreateAge & " days and not accessed in over " & dblMaxAccessedAge & " 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(strFileTypes, Lcase(Right(fil.ShortName,3))) <> 0 Then
If (CDbl(Now) - CDbl(fil.DateCreated)) > dblMaxCreateAge Then
If (CDbl(Now) - CDbl(fil.DateLastAccessed)) > dblMaxAccessedAge 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
Status " Date Accessed " & fil.DateLastAccessed
fil.Delete
End If
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
This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
By continuing to use this site, you are consenting to our use of cookies.