File search and deletion

[patrickm12981]

It runs without error, but does not do what it is supposed to. It should delete the file types specified before it moves the folder. Currently it deletes the USMT_* folder and moves the the folder. So pathing can't be the problem.

Dim objFSO 
Dim rootFolder 
Dim SubFolders 
Dim folder 
Dim fso, sExtToDelete 
Dim nCount 
Function Dday
varYear = year(date) 
varMonth = month(date) 
If len(varMonth) = 1 then 
 varMonth = "0" & varMonth 
End if 
varDay = day(date)-7
If len(varDay) = 1 then 
 varDay = "0" & varDay 
End if 

Dday = varMonth & "-" & varDay & "-" & varYear 
End Function

Set objFSO = CreateObject("Scripting.FileSystemObject") 
' Add folder that requires scanning on next line 
listFolders("\\server\userstate$") 
' Runs only if the folder is more than 7 days old
Sub listFolders(strFolderName)
Set rootFolder = objFSO.GetFolder(strFolderName) 
Set SubFolders = rootFolder.SubFolders 
Set objShell = CreateObject("WScript.Shell")
For Each Folder In SubFolders 
sDay = objFSO.GetBaseName(folder)
If Right(sDay,10) < Dday Then
    WScript.echo(folder) 
      lFolders(folder)
    DirWalk(folder)
    strCmd = "cmd /c robocopy.exe" & " " & strFolderName & "\" & sDay & " " & "\\server2\pcbackup" & "\" & sDay & " " & "/MOVE /ZB /E /R:2 /W:2"
    objShell.Run strCmd, 0, True  
   End If
  Next 
End Sub 
' Deletes the USMT folder
Sub lFolders(strFolderName) 
Set rootFolder = objFSO.GetFolder(strFolderName) 
Set SubFolders = rootFolder.SubFolders 
On Error Resume Next
For Each folder In SubFolders 
    sName = objFSO.GetBaseName(folder)
    If Len(sName) > 5 And Left(sName,5) = "USMT_" Then
        objFSO.DeleteFolder Folder, True 
    End If 
Next 
End Sub 
'EXTENSIONS TO DELETE HERE

sExtToDelete = array(".gif", ".bak", ".mp3") 
nCount = 0 
                  
Wscript.Echo nCount & " files deleted." 
Sub DirWalk(strFolderName) 
Dim oSubDir, oSubFolder, oFile, n 
Dim bDeleted 
On Error Resume Next         
Set rootFolder = objFSO.GetFolder(strFolderName) 
Set SubFolders = rootFolder.SubFolders  
For Each oFile In SubFolders    
If Err.Number = 0 Then 
bDeleted = False 
For n = 0 To UBound(sExtToDelete) 
If LCase(Right(oFile.Name,Len(sExtToDelete(n)))) = sExtToDelete(n) Then 
WScript.Echo "about to delete " & oFile.Path 
ObjFSO.DeleteFile oFile.Path, True 
nCount = nCount + 1 
bDeleted = True 
Exit For 
End If 
Next 
End If 
Next 
For Each oSubDir In oSubFolder.Subfolders 
DirWalk oSubDir.Path       
Next 
On Error Goto 0              
End Sub 

SET objFSO = Nothing