Suppression des sauvegardes obsolètes

Bonjour,

le fichier ci-joint sera utilisé plusieurs fois par jour. DU coup, mon dossier, où la macro me créée une sauvegarde à chaque sortie du fichier, se retrouve avec une multitude de fichiers devenus inutiles. Beaucoup de place perdue sur mon disque dur.

Je sais comment effacer 1 fichier précis dans ce dossier, mais ce que j'aimerais, c'est ne garder que les sauvegardes des 48 dernières heures. Sans demander de confirmation avant écrasement des fichiers.

merci pour votre aide.

Jojo

Bonjour,

Fais un test avec la procédure "DernierFichier48h" (elle utilise deux fonctions). Pour ne pas commettre l'irréparable, fais une copie de tes derniers fichiers inférieur à 48h mais laisses les fichiers originaux (qui sont aussi par là des copies) dans le dossier malgré tout, afin de voir si il sont bien évités :

Sub DernierFichier48h()

    Dim Tbl() As String
    Dim Chemin As String
    Dim Fichier As String
    Dim I As Integer

    Chemin = "C:\Users\Joël\Google Drive\Documents\Cératizit\contrôle des gaz\copie de sauvegarde\"

    Tbl() = ListeFichiers(Chemin, ".xlsm")

    For I = 1 To UBound(Tbl)

        If CDate(ProprietesFichier(Chemin & Tbl(I))) < Now - 2 Then

            On Error Resume Next
            Kill Chemin & Tbl(I) 'attention, les fichiers seront supprimés définitivement ! (sans être mis dans la corbeille)

        End If

    Next I

End Sub

Function ProprietesFichier(Chemin As String) As String

    Dim Fso As Object
    Dim Doc As Object

    If Dir(Chemin) <> "" Then

        Set Fso = CreateObject("Scripting.FileSystemObject")
        Set Doc = Fso.GetFile(Chemin)

        With Doc
            ProprietesFichier = .DateLastModified
        End With

    Else

        ProprietesFichier = "Fichier introuvable"

    End If

    Set Doc = Nothing
    Set Fso = Nothing

End Function

Function ListeFichiers(Chemin As String, _
                       Extension As String) As String()

    Dim Tbl() As String
    Dim Fichier As String
    Dim I As Integer

    Fichier = Dir(Chemin & "*" & Extension)

    Do While (Len(Fichier) > 0)

        If InStr(Fichier, Extension) <> 0 Then

            I = I + 1
            ReDim Preserve Tbl(1 To I)
            Tbl(I) = Fichier

        End If

        Fichier = Dir()

    Loop

    ListeFichiers = Tbl()

End Function

Bonjour Theze,

d'abord merci pour ce code. C'est très sympa!

Je ne suis pas sûr de l'avoir placé au bon endroit dans mon code. Pourriez-vous vérifier svp? J'ai joint le fichier.

Je l'ai essayé, mais rien ne se passe. Il faut dire que je n'ai pas de sauvegarde de plus de 48 h. Du coup, pour essayer votre code, j'ai changé l'heure de mon PC. Mais, toujours rien. Les sauvegardes du 10/3/18 ne sont pas effacées.

Bonjour,

Le code que je t'ai donné peut être mis dans le module standard "Module1" et appelé dans la procédure événementielle "Workbook_BeforeClose()"

Voici ton classeur en retour. J'ai un peu modifié la procédure afin qu'un message t'indique le nombre de classeurs qui ont plus de 48h et si tu souhaites les supprimer

Bonjour et merci Theze !

Je n'en attendais pas temps.

J'ai passé au moins 2 heures à tenter quelque chose. Mon peu d'expérience en VBA a eu raison de moi 😁.

Dès que ma tribu sera réveillée, je fonce allumer mon PC pour essayer le code et surtout, assayer petit à petit, de le comprendre.

Bon dimanche Theze.👍👍👍👍👍

Re,

Content de t'aider, reviens si tu as besoin !

Bonne fin de week-end

Ça marche du tonnerre !!!!

Merci.

Jojo