Déplacement de fichiers d’une grande arborescence

Version imprimable

22/09/2015, 12h04
Ysae68

Déplacement de fichiers d’une grande arborescence

Bonjour à tous,

J’appelle à l’aide car j’ai une tâche à effectuer à mon travail qui est longue, répétitive et ennuyeuse : il s’agit de déplacer des fichiers rangés dans des dossiers, sous-dossiers, sous-sous dossiers (je suis déjà descendue jusqu’à 12 sous-dossiers) pour les mettre dans un autre dossier commun et sans sous-dossiers celui-là (tous les fichiers au même endroit donc). Sachant que l’arborescence à vider de ses fichiers est vraiment très vaste, vous comprendrez bien mon désespoir à devoir ouvrir un à un tous les dossiers qui la composent pour déplacer les fichiers à coup de Ctrl X/Ctrl V.

Je ne connais pas grand-chose au VBS, si ce n’est qu’il devrait être possible qu’un script parcourt toute mon arborescence pour déplacer tous les fichiers rencontrés autre part (sachant que les fichiers en question sont de plusieurs formats : Word, Excel, PowerPoint, PNG, HTML…). J’ai bien trouvé quelques scripts sur le forum qui parlent de déplacement de fichiers, mais très franchement, je n’ai aucune idée de comment les adapter à mon problème :oops:

Si une âme charitable voulait bien se pencher sur mon cas et m’enlever cette épine du pied, ce serait un énorme soulagement pour moi :D

D’avance, merci à ceux qui pourront me consacrer un peu de temps.

Il faudra utiliser la récursivité pour parcourir tous les sous-dossiers.

Mais attention : Si on déplace un fichier vers un dossier qui en contient un du même nom, une erreur se produira et le déplacement s'arrête.

Code:

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
Option explicit
 Dim srcFold  ' Dossier source
 Dim DestFold ' Dossier de destination
 Dim oFSO,oFld,oSubFolder, Fich, FF, WS
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 srcFold = "D:\Fichiers"
 DestFold = "C:\Tmp\"
 Set WS = CreateObject("WScript.Shell")
 Set Fich = oFso.OpenTextFile("Dirs.log", 2, True)' Fichier log listant tous les fichiers copiés/déplacés
 ScanForFiles srcFold
 Fich.Close
 MsgBox "Opération terminée"
'========================
Sub SetFileAttr(sFile)
  ' Il est nécessaire de modifier les attibuts des fichiers
  ' pour pouvoir les copier
  Dim CM
  CM = "Cmd.exe /c Attrib " & sFile & " -r -h -s"
  WS.Run CM, 0, True
End Sub
'=======================
 Sub ScanForFiles (stRep)
    On Error Resume Next ' Juste pour éviter l'erreur : "Le fichier existe déjà"
                         ' Dans ce cas-ci le fichier ne sera pas déplacé
    If oFSO.FolderExists(stRep) Then
       Set oFld = oFSO.GetFolder(stRep)
 
        If oFld.subFolders.count > 0 then 
            Fich.WriteLine     "Nom =  " & oFld.Path    & "  ;  Nombre de sous-dossiers = " & oFld.SubFolders.count
            For Each FF In oFld.Files
                If oFld.Files.count > 0 Then 
                   SetFileAttr FF.Path
                   Fich.WriteLine FF.Name
                   FF.Move DestFold 
                End If
            Next
            Fich.WriteLine "=======Nombre de fichiers = " & oFld.Files.count  &"  ========"
            For each oSubFolder in oFld.subFolders
                ScanForFiles oSubFolder.Path 
            Next
        Else
            If oFld.Files.count > 0 Then 
 
                Fich.WriteLine "=====" & oFld.Name & "=====" 
                For Each FF In oFld.Files
                    Fich.WriteLine FF.Name
                    SetFileAttr FF.Path
                    FF.Move DestFold  
                Next
                Fich.WriteLine "=====Nombre de fichiers = " & oFld.Files.count & "======"
            Else
                Fich.WriteLine     "Dossiers vides : " & oFld.Name  & "  ;  Nombre de sous-dossiers = " & oFld.SubFolders.count
            End If
        End If
    End If
 End sub

23/09/2015, 13h38
Ysae68

Merci beaucoup pour la réponse, c'est vraiment gentil de me donner un coup de main :D

Alors ça marche... presque ! Le fichier log me liste bien toute l'arborescence avec le nombre de fichiers dans chaque dossier (donc le script parcourt bien tous les dossiers et sous dossiers), reste un problème : les fichiers ne sont pas déplacés dans le dossier de destination (ni même copiés, ce dernier reste désespérément vide). J'ai pourtant bien modifié le chemin d'accès de "DestFold", qu'ai-je pu oublié de modifier ? :oops:

On va alors procéder en 2 étapes :
1 - Copier les fichiers de l'arborescence en forçant le remplacement s'il y a lieu
2 - Supprimer les fichiers sources et ce sur demande

Code:

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
77
78
79
80
81
82
Option explicit
 Dim srcFold  ' Dossier source
 Dim DestFold ' Dossier de destination
 Dim oFSO,oFld,oSubFolder, Fich, FF, WS, sMsg
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 srcFold = "D:\Fichiers"
 DestFold = "C:\Tmp\"
 Set WS = CreateObject("WScript.Shell")
 Set Fich = oFso.OpenTextFile("Dirs.log", 2, True)' Fichier log listant tous les fichiers copiés/déplacés
 ScanForFiles srcFold
 Fich.Close
 sMsg = "Copie terminée, Voulez-vous procéder à la suppression des fichiers sources ?"
 If MsgBox(sMsg, VbYesNo, "Supprimer les fichiers sources") = VbYes Then
    DelFiles srcFold
    MsgBox "Suppression terminée"
 Else
    MsgBox "Suppression annulée"
    WScript.Quit 0
End If
'========================
Sub SetFileAttr(sFile)
  ' Il est nécessaire de modifier les attibuts des fichiers
  ' pour pouvoir les copier et écraser ceux qui existeraient dans le dossier cible
  Dim CM
  CM = "Cmd.exe /c Attrib " & sFile & " -r -h -s"
  WS.Run CM, 0, True
End Sub
'=======================
 Sub ScanForFiles (stRep)
    If oFSO.FolderExists(stRep) Then
       Set oFld = oFSO.GetFolder(stRep)
        If oFld.subFolders.count > 0 then 
            Fich.WriteLine     "Nom =  " & oFld.Path    & "  ;  Nombre de sous-dossiers = " & oFld.SubFolders.count
            For Each FF In oFld.Files
                If oFld.Files.count > 0 Then 
                   SetFileAttr FF.Path
                   Fich.WriteLine FF.Name
                   FF.Copy DestFold & FF.name, True
                End If
            Next
            Fich.WriteLine "=======Nombre de fichiers = " & oFld.Files.count  &"  ========"
            For each oSubFolder in oFld.subFolders
                ScanForFiles oSubFolder.Path 
            Next
        Else
            If oFld.Files.count > 0 Then 
 
                Fich.WriteLine "=====" & oFld.Path & "=====" 
                For Each FF In oFld.Files
                    Fich.WriteLine FF.Name
                    SetFileAttr FF.Path
                    FF.Copy DestFold & FF.name, True
                Next
                Fich.WriteLine "=====Nombre de fichiers = " & oFld.Files.count & "======"
            Else
                Fich.WriteLine     "Dossiers vides : " & oFld.Path & "  ;  Nombre de sous-dossiers = " & oFld.SubFolders.count
            End If
        End If
    End If
 End sub
 '===================
 Sub DelFiles(sFold)
    If oFSO.FolderExists(sFold) Then
       Set oFld = oFSO.GetFolder(sFold)
        If oFld.subFolders.count > 0 then 
            For Each FF In oFld.Files
                If oFld.Files.count > 0 Then 
                   FF.Delete True
                End If
            Next
            For each oSubFolder in oFld.subFolders
                DelFiles oSubFolder.Path 
            Next
        Else
            If oFld.Files.count > 0 Then 
                For Each FF In oFld.Files
                    FF.Delete True
                Next
            End If
        End If
    End If
 End Sub

Ne pas oublier de renseigner srcFold et DestFold avec les chemins complets.

30/09/2015, 11h04
Ysae68

Impeccable, merci beaucoup ! :D En plus j'ai une nouvelle flopée de dossiers à traiter qui est arrivée, ça va me faire gagner un temps fou ! Merci, c'est vraiment très gentil de ta part de t'y être accolé :)