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

[ralph45]

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

 

[Dranreb]

Bonjour.
Essayez ça :

Option Explicit
Sub SupprimerSsDos()
   Dim FSO As New Scripting.FileSystemObject, N As Long
   If NbSDosSuppr(FSO.GetFolder("C:\Users\ralph45\Documents")) = 0 Then
      MsgBox "Aucun sous dossier n'a été supprimé.", vbInformation
      End If
   End Sub
Function NbSDosSuppr(ByVal Fdr As Folder) As Long
   Dim SFdr As Folder
   For Each SFdr In Fdr.SubFolders
      NbSDosSuppr = NbSDosSuppr + NbSDosSuppr(SFdr)
      If SFdr.Files.Count + SFdr.SubFolders.Count = 0 Then
         SFdr.Delete
         NbSDosSuppr = NbSDosSuppr + 1
         End If
      Next SFdr
   If NbSDosSuppr > 0 Then MsgBox NbSDosSuppr & " dossiers supprimés dans :" _
      & vbLf & Fdr.Name, vbInformation
   End Function

Référence "Microsoft Scripting Runtime" cochée, évidemment.

 

[M12]

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

Bonjour,
Un test

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

 

[ralph45]

Bonjour ces messieurs et merci de votre réactivité !

Je vais prendre et adapter le code VBA de @Dranreb car il correspond à une gestion totale de suppressions des dossiers, mais je désactiverai la notion de messages, car il m'aurait fallu un nombre total récapitulatif de dossiers supprimés et non un message pour chaque dossier. Mais tant mieux, on gagne en temps de reprise en main.
@M12 : ton code est incomplet, car il me laisse un dossier-père vide et un dossier-fils vide (ou sous-dossier vide). Par contre, il supprime bien les dossiers vides n'ayant pas de sous-dossiers.

Encore merci !

 

[Dranreb]

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

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 …

 

[ralph45]

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

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 …

Super @Dranreb !!

Il manquait juste un petit point :
Case Is > 1: MsgBox " sous dossiers ont été supprimés.", vbInformation
-->
Case Is > 1: MsgBox N & " sous dossiers ont été supprimés.", vbInformation

👍

 

[Dranreb]

Ah oui. Un oubli. Excuses.