Scripting

This is a script I cobbled together ages ago which uses a "shell" I created to be a generic "do stuff with files" script, hence its somewhat convoluted approach. However, it works! So, you pass a bunch of arguments to it like this:

cscript ThisScript.VBS folder_to_search_in extension_of_file_to_process age_of_files_in_days
e.g. cscript ThisScript.VBS c:\windows\temp LOG 180

Then here's the script itself:

'// Creates a dictionary containing details of files in and under a directory.
'// Drop a folder on this script or browse for it. 
Option Explicit
Dim blnResult
Dim intIndex
Dim strMsg
Dim objFSO
Dim objWSHShell
Dim strScriptFullName
Dim objDictionary
Dim strOut
Dim intAge
Dim strMatchCriteria
Const strNameSeparator  = "|"
Const strBrowseForFolderTitle = "Select a folder to process"
strScriptFullName  = WScript.ScriptFullName
Set objFSO    = CreateObject("Scripting.FileSystemObject")
Set objWSHShell   = CreateObject("Shell.Application")
Set objDictionary  = CreateObject("Scripting.Dictionary")
Call Main
Set objDictionary  = Nothing
Set objWSHShell   = Nothing
Set objFSO    = Nothing
Sub Main
 Dim objFolder
 Dim strFolder
 Dim strExtension
 
 '// Get the folder you want info on
 On Error Resume Next
 If WScript.Arguments.Count > 0 Then
  strFolder  = WScript.Arguments(0)
  strExtension = WScript.Arguments(1)
  intAge  = WScript.Arguments(2)
  strMatchCriteria= WScript.Arguments(3)
 Else
  strFolder  = BrowseForFolder(strBrowseForFolderTitle)
 End If
 On Error Goto 0
 
 If Len(strFolder) = 0 Then 
  Exit Sub
 End If
 
 If Len(strExtension) = 0 Then
  strExtension = ".MSI"
 End If
 
 If Len(intAge) = 0 Then
  intAge  = 365
 Else
  intAge  = CInt(intAge)
 End If
 
 If Len(strMatchCriteria) = 0 Then
  strMatchCriteria = "A" '// Use AccessedDate as default
 End If
 
 Call HandleExtension(strExtension, strFolder)
 
End Sub
Sub HandleExtension(ByVal strExt, ByVal strSourceFolder)
 Dim arrDictItems
 Dim arrDictKeys
 Dim strKey
 Dim strItem
 
 '// Don't even bother to start if the destination folder doesn't exist
 If Not objFSO.FolderExists(strSourceFolder) Then
  strMsg  = "The source folder '" & strSourceFolder & "' does not exist."
  MsgBox strMsg, vbOKOnly + vbExclamation
  Exit Sub
 End If
 
 '// Because I decided to call the extension types one by one, 
 '// thus using only one key, rather than x number 
 '// (where 'x' is the number of extensions to be processed)
 '// we need to empty the dictionary
 On Error Resume Next
 objDictionary.RemoveAll
 On Error Goto 0
 
 strOut = ""
 Call RecurseExtensions(objFSO.GetFolder(strSourceFolder), strExt)
 'Call RecurseFiles(objFSO.GetFolder(strSourceFolder))
 
 If IsEmpty(objDictionary) Then
  Exit Sub
 End If
 
 '// Now that we have a dictionary, we can process the items in it
 With objDictionary
  arrDictKeys = .Keys
  arrDictItems = .Items
  
  For intIndex = 0 To .Count - 1
   strKey = arrDictKeys(intIndex)
   strItem = .Item(arrDictKeys(intIndex))
   'WScript.Echo "Key = " & strKey & " Item = "  & strItem
   '// The data looks like this:
   '// Path_to_file, Name_of_file, Size, File type
   '//  separator (see strNameSeparator)
   '// Path_to_file, Name_of_file, Size, File type
   '// etc
   
   '// This next call is what makes this script reasonably generic:
   '// just pass the data to a function which does what you want it to do
   
   blnResult = StartProcessing(strItem)
  Next
 End With
End Sub
Function StartProcessing(ByVal strData)
 Dim arrData
 Dim objFile
 Dim strItem
 Dim strPath
 Dim strName
 Dim strSize
 Dim strType
 Dim strDateCreated
 Dim strDateModified
 Dim strDateAccessed
 Dim strSourceFile
 Dim strDestinationFile
 Dim strCheckDate
 
 '// NB!
 '// When the data gets here, it features an additional first element - the path.
 '// Thus, the index numbers all increase by 1 e.g. the file name is in index 1 rather than 0
 arrData    = Split(strData, strNameSeparator)
 
 QuickSortArray arrData, "(Split(X2)(5)) < (Split(X1)(5))"
 'DisplayResults "Sorted by date", arrData
 '// The data is now in ascending date order.
 '// Now we loop through, creating a new array for files which are OLDER than
 '// the maximum age flag we passed in.
 
 For intIndex = 0 To UBound(arrData)
  strItem  = arrData(intIndex)
  'WScript.Echo strItem
  
  '// Split the data into an array
  strPath  = Split(strItem, ",")(0)
  strName  = Split(strItem, ",")(1)
  strSize  = Split(strItem, ",")(2)
  strType  = Split(strItem, ",")(3)
  strDateCreated = Split(strItem, ",")(4)
  strDateModified = Split(strItem, ",")(5)
  strDateAccessed = Split(strItem, ",")(6)
  strSourceFile  = strPath & "\" & strName
  
  Select Case UCase(strMatchCriteria)
   Case "C"
    strCheckDate = strDateCreated
   Case "A"
    strCheckDate = strDateAccessed
  End Select
  
  If DateDiff("d", strCheckDate, Date) >= intAge Then
   strMsg = ""
   strMsg = strMsg & strPath & ","
   strMsg = strMsg & strName & ","
   strMsg = strMsg & strSize & ","
   strMsg = strMsg & strType & ","
   strMsg = strMsg & strDateCreated & ","
   strMsg = strMsg & strDateModified & ","
   strMsg = strMsg & strDateAccessed
   WScript.Echo strMsg
  End If
 Next
End Function
Sub RecurseExtensions(ByVal objFolderName, ByVal strExt)
 Dim objSubFolders
 Dim objSubFolder
 Dim objFolder
 Dim objFile
 Dim strDetails
 Dim intElement
 Dim strFolderName
 Dim strExtension
 
 strFolderName  = objFolderName.Path
 Set objFolder   = objWSHShell.Namespace(strFolderName)
 If Err.Number <> 0 Then 
  Exit Sub
 End If
 
 '// Write the actual data elements for each file
 For Each objFile in objFolder.Items
  With objDictionary
   If InStr(objFile.Name, ".") Then
    strExtension = UCase(Mid(objFile.Name, InStrRev(objFile.Name, "." ) ) )
    If UCase(strExt) = UCase(strExtension) Then
     Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
     If strOut <> "" Then 
      strOut = strOut & strNameSeparator
     End If
     
     strOut   = strOut & strFolderName
     
     '// We're not interested in the rest of this junk, just:
     '// 0 Name   
     '// 1 Size   
     '// 2 Type   
     '// 3 Date modified  
     '// 4 Date created  
     '// 5 Date accessed  
     
     'For intElement = 0 to 37
     For intElement = 0 To 5
      If strOut <> "" Then 
       strOut = strOut & ","
      End If
      strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
     Next
     
     If Not .Exists(strExtension) Then
      .Add strExtension, strOut
     Else
      .Item(strExtension) = strOut
     End If
    End If
   End If
  End With
 Next
 
 '// Check for any sub-folders and recursively process them
 On Error Resume Next
 Set objSubFolders = objFolderName.SubFolders
 If Err.Number <> 0 Then
  strMsg = "Error " & Err.Number & " occured."
  If Len(Err.Description) > 0 Then
   strMsg = strMsg & vbCRLF & Err.Description
  End If
  WScript.Echo strMsg
 Else
  For Each objSubFolder in objSubFolders
   If LCase(objSubFolder.Name) <> "recycled" Then
    Call RecurseExtensions(objSubFolder, strExt)
   End If
  Next
 End If
 Err.Clear
 On Error Goto 0
 
 Set objFile  = Nothing
 Set objFolder   = Nothing
End Sub
Sub RecurseFiles(ByVal objFolderName)
 Dim objSubFolders
 Dim objSubFolder
 Dim objFolder
 Dim objFile
 Dim strOut
 Dim intElement
 Dim strFolderName
 
 strFolderName = objFolderName.Path
 Set objFolder  = objWSHShell.Namespace(strFolderName)
 If Err.Number <> 0 Then 
  Exit Sub
 End If
 
 '// Write the actual data elements for each file
 For Each objFile in objFolder.Items
  Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0))
  If strOut <> "" Then 
   strOut  = strOut & vbCrLf
  End If
  
  strOut   = strOut & strFolderName
  
  '// We're not interested in the rest of this junk
  'For intElement = 0 to 37
  For intElement = 0 To 2
   If strOut <> "" Then 
    strOut = strOut & ","
   End If
   strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
  Next
  
  Call AddLineToDictionary(strOut)
  strOut = ""
 Next
 
 '// Check for any sub-folders and recursively process them
 Set objSubFolders = objFolderName.SubFolders
 For each objSubFolder in objSubFolders
  If LCase(objSubFolder.Name) <> "recycled" Then
   Call RecurseFiles(objSubFolder)
  End If
 Next
End Sub
Function BrowseForFolder(strPrompt)
 '// Uses "Shell.Application" (only present in Win98 and newer)
 '// to bring up a file/folder selection window. Falls back to an
 '// ugly input box under Win95.
 
 'Shell32.Shell SpecialFolder constants
 Const ssfPERSONAL   = 5   '// My Documents
 Const ssfDRIVES   = 17   '// My Computer
 Const ssfWINDOWS   = 36  '// Windows
 Const SFVVO_SHOWALLOBJECTS  = 1
 Const SFVVO_SHOWEXTENSIONS  = 2 
 Const BIF_RETURNONLYFSDIRS  = &H0001
 Const BIF_EDITBOX   = &H0010
 Const BIF_VALIDATE   = &H0020
 Const BIF_NEWDIALOGSTYLE  = &H0040
 Dim objFolder
 Dim lngView
 Dim strPath
 
 If Instr(TypeName(objWSHShell), "Shell") = 0 Then
  BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(strScriptFullName))
  Exit Function
 End If
 lngView    = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
 lngView    = lngView + BIF_NEWDIALOGSTYLE + BIF_VALIDATE + BIF_EDITBOX + BIF_RETURNONLYFSDIRS
 strPath    = ""
 
 Set objFolder    = objWSHShell.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
 Err.Clear
 
 On Error Resume Next
 strPath    = objFolder.ParentFolder.ParseName(objFolder.Title).Path
 '// An error occurs if the user selects a drive instead of a folder
 '// so handle it here
 Select Case Err.Number
  Case 0
   BrowseForFolder = strPath
  Case 424
   '// User probably selected a drive. Let's see.
   '// First, have a fall-back option
   BrowseForFolder = objFolder.Title
   strPath  = objFolder.Title
   If Len(strPath) > 0 Then
    intIndex = InStr(strPath, ":") 
    If intIndex > 0 Then
     strPath = Mid(strPath, intIndex - 1, 2) & "\"
    End If
   End If
  Case Else
 End Select
 
 '// If the user *types (or pastes) in* an incorrect path, no error is raised
 '// so handle it here
 If Len(strPath) > 0 Then
  '// Only process if something was entered/selected
  If objFSO.FolderExists(strPath) Then
   BrowseForFolder = strPath
   Exit Function
  End If
   
  strMsg  = "The folder '" & strPath & "' does not exist."
  MsgBox strMsg, vbOKOnly + vbExclamation
  BrowseForFolder = ""
 End If
 On Error Goto 0
End Function
Sub Say(strMessage)
 If LCase(Right(WScript.FullName, 12)) = "\cscript.exe" Then
  WScript.Echo strMessage
 End If
End Sub
Sub AddLineToDictionary(ByVal strText)
 '// This routine was designed around AddLineToCSVFile so the string comes in as a CSV line.
 Dim strPath
 Dim strName
 Dim strType
 Dim strSize
 
 strPath    = Split(strText, ",")(0)
 strName    = Split(strText, ",")(1)
 strSize    = Split(strText, ",")(2)
 strType    = Split(strText, ",")(3)
 
 '// Include the path to make the key unique. Without it, subsequent keys wouldn't get added
 '// because the key would already exist. I leave the path in the item because I can use
 '// Split to get at it, rather than string manipulation of the key
 objDictionary.Add strPath & "\" & strName, strSize & strNameSeparator & strType & strNameSeparator & strPath
 
End Sub
Sub AddLineToCSVFile(ByVal strText)
 Dim objTextFile
 Const intForAppending   = 8
 Set objTextFile   = objFSO.OpenTextFile(Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & "csv", intForAppending, True)
 
 With objTextFile
  .WriteLine strText
  .Close
 End With
End Sub
Function FileNameLikeMine(ByVal strFileExtension)
 '// Returns a file name the same as the script name 
 '// except for the file extension. 
 Dim strExtension
 
 strExtension    = strFileExtension
 If Len(strExtension) < 1 Then 
  strExtension   = "txt"
 End If
 
 If strExtension = "." Then 
  strExtension   = "txt"
 End If
 
 If Left(strExtension,1) = "." Then 
  strExtension   = Mid(strExtension, 2)
 End If
 
 FileNameLikeMine   = Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & strExtension
End Function
Sub WriteHeader
 strOut = "Path"
 '// We're not interested in the rest of this junk
 'For intElement = 0 To 37
 For intElement = 0 To 2
  If strOut <> "" Then 
   strOut = strOut & ","
  End If
  
  With objFolder
   strOut = strOut & .GetDetailsOf(.Items, intElement)
  End With
 Next
End Sub
Sub QuickSortArray(ByVal aData(), ByVal strTestRelationship)
'***********************
' Purpose:  Sorts an array using the QuickSort method
'
' Inputs:  aData()   the array to be sorted.
'   strTestRelationship  a string representation of the boolean relationship of 
'      two arbitrary array elements, X1 and X2. The relationship 
'      is true if the elements are in the correct order.
'***********************
  Dim strTestFunction
  '// Create test function by adding function header and tail 
  strTestFunction = "Function TestFunction(X1, X2) : TestFunction = " & strTestRelationship & " : End Function"
  '// Make TestFunction available
  ExecuteGlobal strTestFunction 
  '// Now Call QSort   
  QSort aData, LBound(aData), UBound(aData)
End Sub 'QuickSort
'=====================
Sub QSort(ByVal aData, ByVal iaDataMin, ByVal iaDataMax)
  Dim Temp 
  Dim Buffer 
  Dim iaDataFirst
  Dim iaDataLast
  Dim iaDataMid
  iaDataFirst = iaDataMin                        '// Start current low and high at actual low/high
  iaDataLast = iaDataMax
  If iaDataMax <= iaDataMin Then Exit Sub        '// Error!  
  iaDataMid = (iaDataMin + iaDataMax) \ 2        '// Find the approx midpoint of the array
  Temp = aData(iaDataMid)                        '// Pick as a starting point (we are making
                                                 '// an assumption that the data *might* be
                                                 '// in semi-sorted order already!
  Do While (iaDataFirst <= iaDataLast)
      '// Comparison here
        Do While TestFunction(aData(iaDataFirst), Temp)
          iaDataFirst = iaDataFirst + 1
          If iaDataFirst = iaDataMax Then Exit Do
      Loop
      '// Comparison here
       Do While TestFunction(Temp, aData(iaDataLast))
          iaDataLast = iaDataLast - 1
          If iaDataLast = iaDataMin Then Exit Do
      Loop
      If (iaDataFirst <= iaDataLast) Then        '// If low is <= high then swap
          Buffer = aData(iaDataFirst)
          aData(iaDataFirst) = aData(iaDataLast)
          aData(iaDataLast) = Buffer
          iaDataFirst = iaDataFirst + 1  
          iaDataLast = iaDataLast - 1 
      End If
  Loop
  If iaDataMin < iaDataLast Then                 '// Recurse if necessary
      QSort aData, iaDataMin, iaDataLast
  End If
  If iaDataFirst < iaDataMax Then                '// Recurse if necessary
      QSort aData, iaDataFirst, iaDataMax
  End If
End Sub '// QSort
Sub DisplayResults(ByVal Title, ByVal Data)
 Dim I
 Dim strTemp
 For I = 0 to UBound(Data)
  strTemp = strTemp & Data(i) & vbNewLine
 Next 'i
 MsgBox strTemp, vbOkOnly, Title
End Sub