SUPPRIMER DES FICHIERS EN DOUBLE (D'APRES LEUR NOM)

Private Sub Annuler_Click()

'Ferme le programme
Unload Me

End Sub

Private Sub Dir1_Change()

' Affiche les fichier suivent le dossier
File1.Path = Dir1.Path

End Sub

Private Sub Dir2_Change()

' Affiche les fichier suivent le dossier
File2.Path = Dir2.Path

End Sub

Private Sub Drive1_Change()

' Dit quelle lecteur choisi
Dir1.Path = Drive1.Drive

End Sub

Private Sub Drive2_Change()

' Dit quelle lecteur choisi
Dir2.Path = Drive2.Drive

End Sub

Private Sub Valier_Click()

Dim Ligne, Ligne2, Max, Max2 As Integer
Dim Msg As String

'Message de protection
Msg = MsgBox("Attention vous êtez sur le point de supprimer des fichiers" & vbCrLf & "Continuer ?  ", vbYesNo, "Suppression")
If Msg = vbNo Then Exit Sub ' si on clique sur non on quitte

Ligne = 0
Ligne2 = 0

' Boucle de suppression des fichier en double
Do
Max = File1.ListCount 'Pour longueur maximal
Max2 = File2.ListCount 'Pour longue rmaximal

    File1.ListIndex = Ligne
        Do
            File2.ListIndex = Ligne2
            If File1.FileName = File2.FileName Then
            'Supprimer un Fichier :
            'Cette partit du cose vien de
            'Auteur: tekila_bandita de VB France
            'http://www.vbfrance.com/codes/SUPPRIMER-FICHIER-OU-CATEGORIE-FICHIERS-DANS-REPERTOIRE_32173.aspx
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            objFSO.DeleteFile (File2.Path & "\" & File2.FileName)
            ' Voila jusque ici que je remerci.
            Ligne2 = 0
            End If
            Ligne2 = Ligne2 + 1
        Loop Until Ligne2 = Max2
    Ligne2 = 0
    Ligne = Ligne + 1
Loop Until Ligne = Max

End Sub

Télécharger le zip

04 avril 2007 19:27:13 :

Ajouter un On Error goto Erreur Erreur: exit sub