XL 2010 Bouton - Supprimer photos JPG dans un dossier et ses sous-dossiers

Titi456 · 21 Avril 2023

Bonjour,

Je recherche un code VBA à mettre sur un bouton pour pouvoir supprimer toutes les photos (fichiers .jpg uniquement) qui se trouvent dans un dossier et ses sous-dossiers.

Exemple: si je clique sur le bouton, un explorateur de fichier apparait et je peux sélectionner un dossier pour lequel j'aimerais supprimer toutes les photos JPG se trouvant dans ce dossier et ses sous-dossiers.

Pouvez-vous m'aider?

Mes meilleures salutations,

Thierry

fanch55 · 21 Avril 2023

Pour répondre précisément à la demande :

VB:

Option Explicit
Option Compare Text
Dim Fso As Object
Sub Test()
    Delfile "jpg"
End Sub
Sub Delfile(Optional Ext = "jpg")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then
            Set Fso = CreateObject("Scripting.FileSystemObject")
                KillJpg .SelectedItems(1), Ext
            Set Fso = Nothing
        End If
    End With
End Sub
Sub KillJpg(Folder, Ext)
Dim File, Sf
    Debug.Print Folder
    With Fso.getfolder(Folder)
        For Each File In .Files
            If Fso.GetExtensionName(File) = Ext Then
                Debug.Print vbTab, File.Name
                File.Delete
            End If
        Next...

halecs93 · 21 Avril 2023

Un début de piste

Sub EffacerFichiersJPG()
Dim cheminDossier As String
Dim nomFichier As String

cheminDossier = "chemin_du_dossier_a_nettoyer/" 'Modifier le chemin du dossier selon vos besoins
nomFichier = Dir(cheminDossier & "*.jpg")

Do While nomFichier <> ""
Kill cheminDossier & nomFichier
nomFichier = Dir()
Loop

MsgBox "Tous les fichiers JPG ont été supprimés du dossier."
End Sub

Attention, ça efface sans possibilité de retour en arrière

Titi456 · 21 Avril 2023

Bonjour halecs93,

Merci beaucoup pour votre proposition qui me semble correct mais ça ne fonctionne malheureusement pas chez moi.

Au départ je pensais que c'était à cause de l'extension des fichiers qui n'était pas affichée mais apparemment c'est le code lui-même qui ne fonctionne pas.

Mes meilleures salutations,

Thierry

fanch55 · 21 Avril 2023

Bonjour, vous avez oublié de finir le cheminDossier par "\"

VB:

Option Explicit

Sub EffacerTypeDeFichier()
Dim cheminDossier As String
Dim nomFichier As String

cheminDossier = "C:\Users\tni\Desktop\Nouveau dossier\" 'Modifier le chemin du dossier
nomFichier = Dir(cheminDossier & "*.jpg")

Do While nomFichier <> ""
    Kill cheminDossier & nomFichier
    nomFichier = Dir()
Loop

MsgBox "Tous les fichiers jpg ont été supprimés du dossier."
End Sub

patricktoulon · 21 Avril 2023

Bonjour
@fanch55 et la récursivité pour le".jpg" les subs dossiers ?

fanch55 · 21 Avril 2023

patricktoulon à dit:
Bonjour
@fanch55 et la récursivité pour le".jpg" les subs dossiers ?

Exact, je n'ai regardé que l'origine de l'erreur, pas la demande en elle-même ...

patricktoulon · 21 Avril 2023

re
perso avec dir je le fait mais c'est plus simple avec FSO
avec fso tu peux killer le fichier pendant la boucle for each file in .....
tandis qu'avec dir si tu supprime un fichier le dir n'est plus valide
il faut alors remplir une variable tableau avec les chemins de fichiers et les supprimer dans une seconde boucle

il y en a à foison des exemples ici

patricktoulon · 21 Avril 2023

remarque tu peux tres bien faire si il y a seulement 2 etage dans l'arborecence un

VB:

x= dir(chemin maitre,vbdirectory)
do while  x<>""
if getattr(chemin &"\"& x) and vbdirectory=vbdirectory  then
on error resume next
kill(chemin &"\"& x"\*.jpg"
err.clear
loop
on error goto 0

le on error c'est pour éviter de devoir fair un test dir fichier qui n'est pas possible puisque que dir n'est pas récursif et entrerais en conflit avec le dir vbdirectory

si l'arborescence est plus complexe alors il faudra stocker comme je le disais dans un array les noms (complets) dans une fonction récursive avec dir vbdirectory je dis bien fonction récursive et non un dir recursif

fanch55 · 21 Avril 2023

Pour répondre précisément à la demande :

VB:

Option Explicit
Option Compare Text
Dim Fso As Object
Sub Test()
    Delfile "jpg"
End Sub
Sub Delfile(Optional Ext = "jpg")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then
            Set Fso = CreateObject("Scripting.FileSystemObject")
                KillJpg .SelectedItems(1), Ext
            Set Fso = Nothing
        End If
    End With
End Sub
Sub KillJpg(Folder, Ext)
Dim File, Sf
    Debug.Print Folder
    With Fso.getfolder(Folder)
        For Each File In .Files
            If Fso.GetExtensionName(File) = Ext Then
                Debug.Print vbTab, File.Name
                File.Delete
            End If
        Next
        For Each Sf In .SubFolders
            KillJpg Sf, Ext
        Next
    End With
End Sub

Titi456 · 24 Avril 2023

fanch55 à dit:

Pour répondre précisément à la demande :

VB:

Option Explicit
Option Compare Text
Dim Fso As Object
Sub Test()
    Delfile "jpg"
End Sub
Sub Delfile(Optional Ext = "jpg")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then
            Set Fso = CreateObject("Scripting.FileSystemObject")
                KillJpg .SelectedItems(1), Ext
            Set Fso = Nothing
        End If
    End With
End Sub
Sub KillJpg(Folder, Ext)
Dim File, Sf
    Debug.Print Folder
    With Fso.getfolder(Folder)
        For Each File In .Files
            If Fso.GetExtensionName(File) = Ext Then
                Debug.Print vbTab, File.Name
                File.Delete
            End If
        Next
        For Each Sf In .SubFolders
            KillJpg Sf, Ext
        Next
    End With
End Sub

Bonjour Fanch55,

Mais c'est exactement le code qu'il me fallait. Je peux pas dire mieux. Vous êtes doué!

Merci beaucoup pour votre aide et bon début de semaine à vous tous !

XL 2010 Bouton - Supprimer photos JPG dans un dossier et ses sous-dossiers

Titi456

XLDnaute Junior

fanch55

halecs93

XLDnaute Impliqué

Titi456

XLDnaute Junior

Pièces jointes

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

Titi456

XLDnaute Junior

Discussions similaires