2 dernières copies de sauvergarde

'classeur développé par Flo Cabon
'avec l'aide de macros de John Walkenbach, de Iznogood
' de el-Joker(mpfe)
'16/01/2002
 
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
 
Public Delai
Public Dossier
Public NbFicMax
Dim Nom
Public NextTime
Sub CopieSauvegardeAuto()
    NextTime = Now + TimeValue(Delai)
    Application.OnTime NextTime, "sauve"
End Sub
 
Sub Sauve()
Dim strDate As String
Count = Len(ActiveWorkbook.Name)
Nom = Left(ActiveWorkbook.Name, Count - 4)
strDate = Format(Date, "dd-mm-yy") & " " & Format(time, "h-mm-ss")
ThisWorkbook.SaveCopyAs Filename:=Dossier & Nom & strDate & ".xlsm"
DeleteEnTrop (Dossier)
CopieSauvegardeAuto
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Choisissez un dossier de destination pour les sauvegardes."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Dossier = GetDirectory & "\"
Else
GetDirectory = ""
End If
End Function
 
Sub ChoixDelai()
Delai = InputBox("Entrez sous la forme hh:mm:ss le délai souhaité entre deux sauvegardes" _
& Chr(10) & "ex : 00:30:00 pour enregistrer toutes les 30 minutes", , "00:30:00")
End Sub
Sub ChoixNbSauvegardes()
NbFicMax = InputBox("Combien de sauvegardes voulez vous garder ?" _
& "seules les plus récentes sont conservées", , "4")
End Sub
 
Sub DeleteEnTrop(path)
Dim Fic As String
Dim Tabl() As Variant
Dim i As Integer
'Stocker les noms et les dates de sauvegarde des
'archives dans un tableau
ReDim Tabl(1, 0)
Fic = Dir(path)
Do While Fic <> ""
  ReDim Preserve Tabl(1, UBound(Tabl, 2) + 1)
  Tabl(0, UBound(Tabl, 2)) = Fic
  Tabl(1, UBound(Tabl, 2)) = FileDateTime(path & Fic)
  Fic = Dir
Loop
'S'il y a plus de fichiers que défini dans NbMax
'on trie le tableau des archives par date décroissante
'et on efface les premiers pour n'en laissser
'que le nombre choisi dans NbMax
If UBound(Tabl, 2) > NbFicMax Then
  Tri Tabl, 1, UBound(Tabl, 2)
  For i = UBound(Tabl, 2) To NbFicMax + 1 Step -1
   Kill path & Tabl(0, i)
  Next i
End If
End Sub
'Procédure récursive classique
'de tri adaptée au tri d'un
'tableau à 2 dimensions
Sub Tri(ByRef Liste As Variant, ByVal Bas As Long, ByVal Haut As Long)
Dim i  As Long, j As Long
Dim Milieu As Variant, Echange As Variant
  i = Bas
  j = Haut
  Milieu = Liste(1, Int(Bas + Haut) / 2)
  Do
    While Liste(1, i) > Milieu
      i = i + 1
    Wend
    While Milieu > Liste(1, j)
      j = j - 1
    Wend
    If i <= j Then
      Echange = Liste(1, i)
      Liste(1, i) = Liste(1, j)
      Liste(1, j) = Echange
      Echange = Liste(0, i)
      Liste(0, i) = Liste(0, j)
      Liste(0, j) = Echange
      i = i + 1
      j = j - 1
    End If
  Loop Until i > j
  If Bas < j Then Tri Liste, Bas, j
  If i < Haut Then Tri Liste, i, Haut
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Range("a1").Select
    If Arrêt = False Then
        'Ferme et enregistre le classeur.
        ThisWorkbook.Close SaveChanges:=True
    Else
        Application.OnTime NextTime, "sauve", schedule:=False
    End If
End Sub
Private Sub Workbook_Open()
 With Sheets("sommaire")
     If .Range("F13") <> "" And .Range("F14") <> "" Then Exit Sub
     'End If
 End With
 sauver = MsgBox("Voulez activer la sauvegarde automatique pour ce classeur ?", vbYesNo)
 If sauver = vbNo Then
     Exit Sub
 Else
     SauvegardeAuto = True
     GetDirectory
     ChoixDelai
     ChoixNbSauvegardes
     Sauve
 End If
 End Sub