Bonjour,

Je ne sais pas si c'est le bon endroit pour poster, mais les personnes interréssées sauront trouver l'info.

Pour créer un équivalent XCopy /D (dos) en VBA (pour ne copier que les fichiers les plus récents)

La référence "Microsofr Scripting RunTime" doit être cochée

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Option Explicit
 
Dim oFSO As New FileSystemObject
Dim oTXT As Scripting.TextStream
Dim FichiersCréés%, FichierRemplacés%, DossiersCréés%
 
 
Private Sub Sauvegarde()
 
    Dim oFLDSource As Scripting.Folder, oFLDCible As Scripting.Folder
    Dim oSubFoldSource As Scripting.Folder, oSubFoldCible As Scripting.Folder
    Dim oFileSource As Scripting.File, oFileCible As Scripting.File
    Dim HeureDebut As Date
    Dim Source$, Cible$
 
    Source = "D:\Analyst Data"
    Cible = "R:\API3000"
 
    HeureDebut = Now
 
    If Not oFSO.FolderExists Then oFSO.CreateFolder Cible 'Crée le fichier Cible s'il n'existe pas
 
    Set oFLDSource = oFSO.GetFolder(Source)
    Set oFLDCible = oFSO.GetFolder(Cible)
    Set oTXT = oFSO.OpenTextFile(Cible & "\Sauvegarde.txt", ForAppending)
    oTXT.WriteLine "Sauvegarde du " & Now
    For Each oSubFoldSource In oFLDSource.SubFolders
        VerificationSubFolder oSubFoldSource, oFLDSource.Path, oFLDCible.Path
    Next
    With oTXT
        .WriteLine (FichiersCréés & " fichier(s) créé(s)")
        .WriteLine (FichierRemplacés & " fichier(s) remplacé(s)")
        .WriteLine (DossiersCréés & " Dossier(s) créé(s)")
        .WriteLine "Fin de transfert : " & Now & " (" & Round((Now - HeureDebut) * 1500, 3) & " minutes)"
        .Close
    End With
 
End Sub
 
Private Sub VerificationSubFolder(oFldS As Scripting.Folder, DossierSource$, DossierCible$)
 
    Dim oSubFolderSource As Scripting.Folder, oSubFolderCible As Scripting.Folder
    Dim oFld As Scripting.Folder
    Dim oflSource As Scripting.File, oflCible As Scripting.File
    If oFSO.FolderExists(Replace(oFldS.Path, DossierSource, DossierCible)) Then
        Set oFld = oFSO.GetFolder(Replace(oFldS.Path, DossierSource, DossierCible))
            For Each oflSource In oFldS.Files
                'Vérification existence des fichiers dans le dossier cible
                If oFSO.FileExists(Replace(oflSource.Path, DossierSource, DossierCible)) Then
                    'Fichier existe dans le dossier cible
                    Set oflCible = oFSO.GetFile(Replace(oflSource.Path, DossierSource, DossierCible))
                    'Comparaison des dates de modification
                    If oflCible.DateLastModified < oflSource.DateLastModified Then
                        'Fichier Source plus récent que le fichier cible
                        oTXT.WriteLine ("Remplacement du fichier " & oflSource)
                        'Copie du fichier avec ecrasement du fichier cible en respectant l'arborescence
                        oflCible.Copy Replace(oflSource.Path, DossierSource, DossierCible), True
                        FichierRemplacés = FichierRemplacés + 1
                    End If
                Else 'Le fichier cible n'existe pas
                    oTXT.WriteLine ("Copie du fichier " & oflSource)
                    oflCible.Copy Replace(oflSource.Path, DossierSource, DossierCible)
                    FichiersCréés = FichiersCréés + 1
                End If
            Next
            For Each oSubFolderSource In oFldS.SubFolders
                VerificationSubFolder oSubFolderSource, DossierSource, DossierCible
            Next
    Else
        oTXT.WriteLine ("Création du dossier " & oFldS.Path)
        DossiersCréés = DossiersCréés + 1
        oFldS.Copy Replace(oFldS.Path, DossierSource, DossierCible)
    End If
 
 
End Sub

En VBS : Copier le texte suivant dans un fichier BlocNote, enregistrer sous "Sauvegarde.vbs", puis plannifier une tâche par le planificateur de tache Windows pour effectuer la sauvegarde quotidiennement:


Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Dim FichiersCrees, FichierRemplaces, DossiersCrees, oTXT, Source, Cible
 
FichiersCrees=0
FichierRemplaces=0
DossiersCrees =0
Set oFSO = CreateObject("Scripting.FileSystemObject")
HeureDebut = Now
 
Source="C:\Xcalibur"
Cible="R:\Focus"
 
If Not oFSO.FolderExists(Cible) Then oFSO.CreateFolder (Cible)
 
Set oFLDSource = oFSO.GetFolder(Source)
Set oFLDCible = oFSO.GetFolder(Cible)
set oTXT=oFSO.OpenTextFile(cible & "\Sauvegarde.txt", 8, true)
 
oTXT.WriteLine " " 
oTXT.WriteLine "Sauvegarde du " & Now
For Each oSubFoldSource In oFLDSource.SubFolders
  VerificationSubFolder oSubFoldSource, oFLDSource.Path, oFLDCible.Path
Next
oTXT.WriteLine (FichiersCrees & " fichier(s) créé(s)")
oTXT.WriteLine (FichierRemplaces & " fichier(s) remplacé(s)")
oTXT.WriteLine (DossiersCrees & " Dossier(s) créé(s)")
oTXT.WriteLine "Fin de transfert : " & Now & " (" & round((Now - HeureDebut)*1500,3) & " minutes)"
oTXT.Close
 
 
Sub VerificationSubFolder(oFldS, DossierSource, DossierCible)    
  If oFSO.FolderExists(Replace(oFldS.Path, DossierSource, DossierCible)) Then
    Set oFld = oFSO.GetFolder(Replace(oFldS.Path, DossierSource, DossierCible))
    For Each oflSource In oFldS.Files
      If oFSO.FileExists(Replace(oflSource.Path, DossierSource, DossierCible)) Then
        Set oflCible = oFSO.GetFile(Replace(oflSource.Path, DossierSource, DossierCible))
        If oflCible.DateLastModified < oflSource.DateLastModified Then
          oTXT.WriteLine ("Remplacement du fichier " & oflSource)
          oflCible.Copy Replace(oflSource.Path, DossierSource, DossierCible), True
	  FichierRemplaces = FichierRemplaces + 1
        End If
      Else 'Le fichier cible n'existe pas
	oTXT.WriteLine ("Copie du fichier " & oflSource)
	oflSource.Copy Replace(oflSource.Path, DossierSource, DossierCible)
	FichiersCrees = FichiersCrees + 1
      End If
    Next
    For Each oSubFolderSource In oFldS.SubFolders
	VerificationSubFolder oSubFolderSource, DossierSource, DossierCible
    Next
  Else
    oTXT.WriteLine ("Création du dossier " & replace(oFldS.Path, DossierSource, DossierCible))
    DossiersCrees = DossiersCrees + 1
    oFldS.Copy Replace(oFldS.Path, DossierSource, DossierCible)
  End If  
End Sub