Deleting excel files from multiple folders

[raj08536]

I have a VBA code to copy excel files from one folders to multiple folders. I need now to delete them all.

Here is vb ccode for copying.

Public Sub CopyTemplates()
    Dim DB As New clsDB, rst As New ADODB.Recordset
    Dim FileName As String, OK As Boolean, i As Integer, ErrorMessage As String
   
    Application.EnableCancelKey = xlDisabled
    On Error GoTo ERRORFUN
   
    ' Log
    Call LogEvent("Copy Templates", 2)
   
    ' Start
    Call ClearStatus("TEMPLATE COPY")
    Call SetPath
   
    rst.CursorLocation = adUseClient
   
    ' Initializse Connection
    If Not DB.OpenConnection Then
        ErrorMessage = "ERROR: Could not open connection"
        GoTo ERRORFUN2
    End If
   
    ' Execute SP
    If Not DB.ExecuteGetSP("budget.get_acct_units_folders", "", rst) Then
        ErrorMessage = "ERROR: Could not execute SP get_acct_units_folders"
        GoTo ERRORFUN2
    End If
   
    'Loop within AUs
    OK = True
    Do While Not rst.EOF
        OK = CheckFolderExists(rst.Fields("folder"), False) And OK
        rst.MoveNext
    Loop
   
    If Not OK Then
        ErrorMessage = "ERROR: Check Folders failed"
        GoTo ERRORFUN2
    End If
   
    rst.Close
   
    ' Get Accounting Units
    If Not DB.ExecuteGetSP("budget.get_acct_units_to_copy", "", rst) Then
        ErrorMessage = "ERROR: Could not execute SP get_acct_units_to_copy"
        GoTo ERRORFUN2
    End If
   
    Total = rst.RecordCount
    If Total = 0 Then Increment = 0 Else Increment = 1 / Total
    ThisWorkbook.Worksheets("Main").Cells(3, 1) = "SUCCEEDED: 0   |   FAILED: 0   |   TOTAL: 0 / " & Total
   
    'Loop within AUs
    Do While Not rst.EOF
        ' Check if is cancel
        If CancelProcess Then Exit Do
   
        FileName = GetFileNameFromPath(rst.Fields("file_path"))
       
        Call AddStatus(Trim(rst.Fields("site")) & Trim(rst.Fields("acct_unit")))
               
        OK = True
       
        'Copy from Template (if it doesnt exist)
        If OK Then OK = FileExists(PathTemplates & FileName)
       
        ' Check if folder exists
        If OK Then
            OK = CheckFolderExists(GetFolderFromPath(rst.Fields("file_path")), True, False)
            If Not OK Then OK = CreateFolder(GetFolderFromPath(rst.Fields("file_path")))
        End If
       
        'Copy from template
        If OK Then OK = CopyFile(PathTemplates & FileName, rst.Fields("file_path"))
       
        ' Flag as generated
        If OK Then Call FlagCopied(DB, rst.Fields("site"), rst.Fields("acct_unit"))
       
        ' Update RefreshBar
        Call RefreshStatusBar(OK)
       
        rst.MoveNext
    Loop
   
    If rst.EOF Then
        ThisWorkbook.Worksheets("Main").Cells(2, 1) = 1
    End If
       
    ' Close Recordsets
    rst.Close
    Call DB.CloseConnection
   
    Call AddStatus("FINISHED")
   
    MsgBox "Done!", , "Status"
   
    Call LockMain(True)
   
    Exit Sub
ERRORFUN:
    ErrorMessage = Err.Number & ": " & Err.Description
    Call NewMsgBox(ErrorMessage, vbCritical, "Error generating templates")
   
ERRORFUN2:
    Call AddStatus("CRITICAL ERROR " & ErrorMessage)
   
    If DB.Opened Then
        rst.Close
        Call DB.CloseConnection
    End If
   
    Call LockMain(True)
End Sub

 

[ExcelGzh]

Here's what I use to delete files with the same name across multiple folders. In this case Thumbs.db.

Sub DeleteFilesMaster()
  Dim Folder1 As Object
  Dim fso As Object
  Dim Temp As Variant
  Dim xPath As String
 
  On Error GoTo ErrorRoutine
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    Temp = .Show
  End With
  If Temp = True Then
    xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    If Right(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1), 1) <> "\" Then xPath = xPath & "\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Folder1 = fso.getFolder(xPath)
    DeleteFilesSubFolders Folder1
  End If 'Temp = True

ExitRoutine:
  Exit Sub
ErrorRoutine:
  ErrorMsgNum = Err.Number
  ErrorMsgDesc = Err.Description
  MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module DeleteFile"
  Resume ExitRoutine
End Sub 'DeleteFilesMaster

Sub DeleteFilesSubFolders(ByRef prntfld As Object)
  Dim Folder2 As Object
  Dim fso As Object
  Dim sFile As String
  Dim SubFolder As Object
  Dim subfld As String
  Dim Temp As Variant
  Dim xRowTemp As Long

  On Error GoTo ErrorRoutine
  subfld = prntfld.Path
  If Right(subfld, 1) <> "\" Then subfld = subfld & "\"

 sFile = subfld & "Thumbs.db" 'This will need to be modified to suit whatever it is that needs deleting
  'Check File Exists or Not
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(sFile) Then
    'If file exists, It will delete the file
    On Error Resume Next
    fso.DeleteFile sFile, True
    On Error GoTo ErrorRoutine
  Else
    'If file does not exists, It will do nothing
  End If
 
  'After deleting the files in this folder, look to see if there are sub-folders in this folder
  For Each SubFolder In prntfld.subfolders
    If prntfld.subfolders.Count > 0 Then
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set Folder2 = fso.getFolder(subfld)
      DoEvents
      'If a subfolder is encountered that the user does not have permission for an error will occur
      If Folder2.subfolders.Count > 0 Then DeleteFilesSubFolders Folder2
SkipSubFolder:
      On Error GoTo ErrorRoutine
    End If 'prntfld.subfolders.Count > 0
  Next SubFolder

ExitRoutine:
  Exit Sub
ErrorRoutine:
  ErrorMsgNum = Err.Number
  If ErrorMsgNum = 52 Then Resume SkipSubFolder 'Permission denied
  If ErrorMsgNum = 70 Then Resume SkipSubFolder 'Permission denied
  ErrorMsgDesc = Err.Description
  MsgBox ErrorMsgNum & " " & ErrorMsgDesc & " in module DeleteFilesSubFolders"
  Resume ExitRoutine

End Sub 'DeleteFilesSubFolders