Microsoft 365 Résolu [VBA] Suppression de sous-dossiers et dossiers vides

ralph45 à dit:

Bonjour la communauté ED,

En cherchant sur ce forum et chez feu JBoisgontier, je n'ai pas trouvé de solution exacte à mon questionnement :
comment supprimer de façon automatique les sous-dossiers et les dossiers vides d'un emplacement précis ?
Difficile de joindre un fichier-exemple dans ce contexte... mais je vais essayer d'être explicite.

Exemple & spécificités

sous C:\Users\ralph45\Documents\

--> Supprimer en arborescence ascendante le.s dossier.s vide.s :

1° le dossier-père a "x" dossiers-fils dont 4 vides , ne supprimer que ce.s dossier.s-fils
2° le dossier-père ne doit être supprimé que si le.s dossier-fils est/sont vide.s.
3° et une boucle qui remonte l'arborescence jusqu'à "C:\Users\ralph45\Documents\"

NB Cerise sur le gâteau (de Noël et pas une bûche), message informatif de "x" dossier.s supprimé.s

En attendant vos suggestions, je vous adresse mes meilleurs vœux de fêtes et de fin d'année...
Et surtout, abusez de tout avec modération ! 🥳

ralph45

Cliquez pour agrandir...

Sub SuppDoss()
  Dim FSO As Object, Dossier As String, Doss As Object, D1 As Object, OK As Boolean
  Dossier = "C:\Users\ralph45\Documents"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set Doss = FSO.getfolder(Dossier)
  For Each D1 In Doss.subfolders
    If D1.subfolders.Count + D1.Files.Count = 0 Then
      OK = True
      If OK = True Then D1.Delete True
    Else
      OK = False
    End If
  Next D1
 
End Sub

Dranreb à dit:

Une version avec possibilité d'enlever confirmation et message :

VB:

Option Explicit
Sub SupprimerSsDos()
   Dim FSO As New Scripting.FileSystemObject, N As Long
   N = NbSDosSuppr(FSO.GetFolder("C:\Users\ralph45\Documents"), Toujours:=True)
   Select Case N
      Case Is > 1: MsgBox " sous dossiers ont été supprimés.", vbInformation
      Case 1: MsgBox "Un sous dossier a été supprimé.", vbInformation
      Case Else: MsgBox "Aucun sous dossier n'a été supprimé.", vbInformation
      End Select
   End Sub
Function NbSDosSuppr(ByVal Fdr As Folder, Optional ByVal Toujours As Boolean) As Long
   Dim SFdr As Folder, Supprimer As Boolean
   On Error GoTo E
   For Each SFdr In Fdr.SubFolders
      NbSDosSuppr = NbSDosSuppr + NbSDosSuppr(SFdr, Toujours)
      If SFdr.Files.Count + SFdr.SubFolders.Count = 0 Then
         If Toujours Then
            Supprimer = True
         Else
            Supprimer = MsgBox("""" & SFdr.Name & """ vide." _
               & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
               & vbLf & "À supprimer ?", vbYesNo, "NbSDosSuppr(Fdr)") = vbYes
            End If
         If Supprimer Then
            SFdr.Delete
            NbSDosSuppr = NbSDosSuppr + 1
            End If
         End If
      Next SFdr
   If Toujours Then Exit Function
   If NbSDosSuppr > 0 Then MsgBox NbSDosSuppr & " dossiers supprimés dans :" _
      & vbLf & Fdr.Name, vbInformation
   Exit Function
E: Select Case MsgBox("Erreur " & Err _
      & vbLf & "Fdr.Path = """ & Fdr.Path & """." _
      & vbLf & Err.Description, vbExclamation + vbAbortRetryIgnore, "NbSDosSuppr(Fdr)")
      Case vbRetry: On Error GoTo 0: Resume
      Case vbIgnore: Resume Next
      End Select
   End Function

À tester prudemment …

Cliquez pour agrandir...