'avec l'aide de John Walkenbach, de Iznogood et de el-Joker(mpfe)
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 & ".xltm"
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