XL 2016 VBA Enrigistrement fichier de sauvegarde

[Eric CARIOLI]

Bonjour, je voudrais à l'aide d'une macro que le fichier dans lequel il y a la macro soit sauvegardé dans un répertoire défini avec le nom du fichier avec la date et l'heure avant que la macro principale soit lancée. Quelle fonction et quel petit sous-programme puis je utiliser?
Merci

Eric

 

[piga25]

Bonjour,

Pour ma part j'utilise cela :

'
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

 

[cathodique]

Bonjour,

Bienvenue sur XLD. Stp, la prochaine fois joins un petit fichier.

Vois si ça te conviens. Le répertoire doit au préalable existé.