Déplacement fichiers multimédias et créations de raccourcis

Version imprimable

Bonjour,
J'ai besoin de faire un script qui déplace les fichiers multimédias (images, sons et vidéos) depuis un plan de classement situé sur un serveur vers un plan de classement miroir, sur lequel ne se trouveront que les fichiers multimédias.
L'arborescence sera identique pour tous les répertoires contenant des fichiers multimédias.
Il faudrait qu'en plus, il crée des raccourcis lors du déplacement des fichiers multimédias vers le nouveau plan de classement, afin qu'on puisse ouvrir ces fichiers sans galérer.
J'ai récupéré un script qui réalise une partie du travail.
- Déplacement des fichiers multimédias depuis le répertoire source vers le répertoire destination -> OK
- Par contre, concernant les sous-rép. le script déplace tous les fichiers et pas seulement les fichiers images...

Pour l'instant je n'ai sélectionné que les .tif et .png, mais il faudra ajouter quelques dizaines d'extensions supplémentaires.
Je mets le script ci-dessous.
Merci d'avance pour l'aide que vous pourrez m'apporter.
Dan

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
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
 
strDestination = "D:\temp\Test\2-Arrivee\"
strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
 
If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
strSource = "D:\temp\Test\1-Depart\"
 
Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
objLogFile.WriteLine "Script started: " & Now
objLogFile.WriteLine "Copying files from: " & strSource & " to " & strDestination & VbCrLf
 
For Each objFile In objFSO.GetFolder(strSource).Files
'	If Right(LCase(objFile.Name), 4) <> ".lnk" And Right(LCase(objFile.Name), 4) <> ".url" Then
	If Right(LCase(objFile.Name), 4) = ".tif" Or Right(LCase(objFile.Name), 4) = ".png" And Right(LCase(objFile.Name), 4) <> ".url" Then	
		If objFSO.FileExists(strDestination & objFile.Name) = True Then
			objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
		Else
			strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
			On Error Resume Next
			objFSO.MoveFile objFile.Path, strDestination
			If Err.Number = 0 Then
				objLogFile.WriteLine "Copied file " & objFile.Name
				CreateShortcut strBaseName & ".lnk", strDestination
				objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
			Else
				objLogFile.WriteLine "Error copying file " & objFile.Name & ". Error " & Err.Number & ": " & Err.Description
			End If
			Err.Clear
			On Error GoTo 0
		End If
	End If
Next
 
objLogFile.WriteLine VbCrLf & "Copying folders from: " & strSource & " to " & strDestination & VbCrLf
For Each objFolder In objFSO.GetFolder(strSource).SubFolders
	If objFSO.FolderExists(strDestination & objFolder.Name) = True Then
		objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
	Else
		On Error Resume Next
		objFSO.MoveFolder objFolder.Path, strDestination
		If Err.Number = 0 Then
			objLogFile.WriteLine "Copied folder " & objFolder.Name
		Else
			objLogFile.WriteLine "Error copying folder " & objFolder.Name & ". Error " & Err.Number & ": " & Err.Description
		End If
		Err.Clear
		On Error GoTo 0
	End If
Next
 
MsgBox "Done"
 
Sub CreateShortcut(strName, strTarget)
	Set objShell = CreateObject("WScript.Shell")
	Set objLink = objShell.CreateShortcut(strName)
	objLink.TargetPath = strTarget
	objLink.Save
End Sub

Pour éviter les répétitions, tu peux définir un tableau pour les extensions à traiter puis une fonction booléenne qui vérifie si un fichier possède l'extension voulue.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Dim arrExtension
arrExtension = Array("tif", "jpg", "bmp", "png", .....)
' La fonction
Function VerifExtension(sFileName)
  Dim I
  For i = 0 To Ubound(arrExtension)
     If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
        VerifExtension = True
        Exit For
     End If
 Next
End Function

et l'appel de la fonction se fait ainsi

Code:

1
2
3
For Each objFile In objFSO.GetFolder(strSource).Files
     If VerifExtension(objFile.Path) Then
          ' ... ton traitement ici

Bonjour et merci pour l'aide apportée.
C'est effectivement une bonne idée qui permet de traiter tous les types de fichiers images... sans alourdir la procédure.
Il faudrait que le script traite les sous-répertoires comme le répertoire initial, c'est à dire déplacer uniquement les fichiers multimédias.
Merci d'avance pour votre aide et conseils
Dan

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
Dim arrExtension
arrExtension = Array("tif", "jpg", "bmp", "png")
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
 
strDestination = "D:\temp\Test\2-Arrivee\"
strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
 
If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
strSource = "D:\temp\Test\1-Depart\"
 
Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
objLogFile.WriteLine "Script started: " & Now
objLogFile.WriteLine "Copying files from: " & strSource & " to " & strDestination & VbCrLf
 
For Each objFile In objFSO.GetFolder(strSource).Files
    If VerifExtension(objFile.Path) Then
'	If Right(LCase(objFile.Name), 4) <> ".lnk" And Right(LCase(objFile.Name), 4) <> ".url" Then
	If Right(LCase(objFile.Name), 4) = ".tif" Or Right(LCase(objFile.Name), 4) = ".png" And Right(LCase(objFile.Name), 4) <> ".url" Then	
		If objFSO.FileExists(strDestination & objFile.Name) = True Then
			objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
		Else
			strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
			On Error Resume Next
			objFSO.MoveFile objFile.Path, strDestination
			If Err.Number = 0 Then
				objLogFile.WriteLine "Copied file " & objFile.Name
				CreateShortcut strBaseName & ".lnk", strDestination
				objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
			Else
				objLogFile.WriteLine "Error copying file " & objFile.Name & ". Error " & Err.Number & ": " & Err.Description
			End If
			Err.Clear
			On Error GoTo 0
		End If
	End If
	End If
Next
 
objLogFile.WriteLine VbCrLf & "Copying folders from: " & strSource & " to " & strDestination & VbCrLf
For Each objFolder In objFSO.GetFolder(strSource).SubFolders
	If objFSO.FolderExists(strDestination & objFolder.Name) = True Then
		objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
	Else
		On Error Resume Next
		objFSO.MoveFolder objFolder.Path, strDestination
		If Err.Number = 0 Then
			objLogFile.WriteLine "Copied folder " & objFolder.Name
		Else
			objLogFile.WriteLine "Error copying folder " & objFolder.Name & ". Error " & Err.Number & ": " & Err.Description
		End If
		Err.Clear
		On Error GoTo 0
	End If
Next
 
MsgBox "Done"
 
Sub CreateShortcut(strName, strTarget)
	Set objShell = CreateObject("WScript.Shell")
	Set objLink = objShell.CreateShortcut(strName)
	objLink.TargetPath = strTarget
	objLink.Save
End Sub          
 
Function VerifExtension(sFileName)
  Dim I
  For i = 0 To Ubound(arrExtension)
     If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
        VerifExtension = True
        Exit For
     End If
 Next
End Function

11/11/2018, 12h00
l_autodidacte
J'ai des questions sur le déplacement:
1. Que fait-on pour les fichiers qui ne sont pas du type multimédia ?
2. Que fait-on pour les fichiers qui ne seront pas déplacés ?
3. Idem pour les sous-dossiers ?
La réponse à ces questions peut aider à concevoir le script voulu.
11/11/2018, 15h10
Dan25
Citation:
Envoyé par l_autodidacte

J'ai des questions sur le déplacement:

Pour expliquer un peu le pourquoi du script :
On cherche à gagner de la place sur les serveurs de fichiers en déplaçant les fichiers mulitmédias qui représentent de gros volumes sur un NAS.
Pour que la recherche soit facilitée, je voudrais placer des raccourcis dans le plan de classement original et pointant sur les nouveaux emplacements des fichiers déplacés.

Que fait-on pour les fichiers qui ne sont pas du type multimédia ?
Tous les fichiers qui ne sont pas multimédias, restent en place
Que fait-on pour les fichiers qui ne seront pas déplacés ?
Ils restent au même emplacement
Idem pour les sous-dossiers ?
Les sous-dossiers restent aussi au mêmes emplacements s'ils ne sont pas vides après le déplacement des fichiers multimédias.

La réponse à ces questions peut aider à concevoir le script voulu.

Avant de tester le code, fais une copie du dossier à traiter :

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
83
Option Explicit' Déclaration obligatoire des variables
Dim arrExtension, objShell, objFSO, objNetwork, strDestination, strLogFile, strSource, objLogFile, objFile, strBaseName, NewFolder, objFolder
 
arrExtension = Array("tif", "jpg", "bmp", "png")
 
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
 
strDestination = "D:\temp\Test\2-Arrivee\"
strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
 
If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
strSource = "D:\temp\Test\1-Depart\"
 
Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
objLogFile.WriteLine "Script started: " & Now
 
RecurseFolders strSource, strDestination
 
objLogFile.Close
MsgBox "Done"
'====================================
Private Sub RecurseFolders(srcFolder, DestFolder)
    Dim NomFichier, CheminFichier
    If objFSO.GetFolder(srcFolder).Files.Count = 0  Then 
         objLogFile.WriteLine "No file to copy from : " & srcFolder  & VbCrLf
    Else     
         objLogFile.WriteLine "Copying files from: " & srcFolder & " to " & DestFolder & VbCrLf
    End If
    For Each objFile In objFSO.GetFolder(srcFolder).Files
        If VerifExtension(objFile.Path) Then
            If objFSO.FileExists(DestFolder & "\" & objFile.Name) Then
                objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
            Else
                'strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
                strBaseName = objFSO.GetBaseName(objFile.Path)
                'On Error Resume Next ' Toujours utiliser avec précaution car cela cache les erreurs
                NomFichier = objFile.Name
                CheminFichier = objFile.Path
                objFSO.MoveFile objFile.Path, DestFolder & "\"
                If Err.Number = 0 Then
                    objLogFile.WriteLine "Copied file " & NomFichier
                    ' Création des raccourcis dans le dossier principal(à vérifier selon ce dont tu as besoin)
                    CreateShortcut strDestination & "\" & strBaseName & ".lnk", CheminFichier
                    objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
                Else
                    objLogFile.WriteLine "#### Error copying file " & NomFichier & ". Error " & Err.Number & ": " & Err.Description
                End If
                Err.Clear
                On Error GoTo 0
            End If
        End If
    Next
' On utilise la récursivité pour traiter tous les sous-dossiers    
    For Each objFolder In objFSO.GetFolder(srcFolder).SubFolders
        If  objFSO.FolderExists(DestFolder & "\" & objFolder.Name)  Then
            objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
        Else
            Set NewFolder = objFSO.CreateFolder(DestFolder & "\" & objFolder.Name)
            Call RecurseFolders(objFolder.Path, NewFolder.Path)
        End If
    Next
End Sub
'==================================
Sub CreateShortcut(strName, strTarget)
    Dim objShell, objLink
    Set objShell = CreateObject("WScript.Shell")
    Set objLink = objShell.CreateShortcut(strName)
    objLink.TargetPath = strTarget
    objLink.WorkingDirectory = Left(strName, InStrRev(strName, "\")-1)
    objLink.Save
End Sub          
'==================================
Function VerifExtension(sFileName)
  Dim I
  For i = 0 To Ubound(arrExtension)
     If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
        VerifExtension = True
        Exit For
     End If
 Next
End Function

12/11/2018, 13h35
Dan25

Bonjour et merci pour ce joli travail !
Il reste 2 points qui ne fonctionnent pas comme il faudrait :
1- les raccourcis doivent figurer dans le plan de classement initial, afin qu'en cliquant sur ceux-ci, l'ouverture du fichier multimédia s'effectue depuis le NAS
2- pour l'instant, les raccourcis ne sont créés que dans les 2 répertoires initiaux et pas dans les sous-répertoires (les fichiers multimédias, eux sont bien déplacés)

Un autre problème qui me paraît plus bizarre : certaines fois des fichiers ne sont pas transférés dans certains sous-répertoires, sans que la structure ait été modifiée et en conservant les mêmes fichiers.
Parfois il en reste 1 ou plusieurs, parfois tous ???

Merci encore pour l'aide fournie et le temps passé.
Bien cordialement
Daniel
12/11/2018, 19h19
l_autodidacte
1. Que veux-tu dire par Plan de classement initial ?
2. Les raccourcis doivent pointer vers quels fichiers(ceux copiés je suppose) et où doivent-il être placés ?
3. As-tu vérifié les attributs des fichiers non déplacés ? car si ReadOnly, il faut désactiver cet attribut.
12/11/2018, 20h12
Dan25
Citation:
Envoyé par l_autodidacte

Que veux-tu dire par Plan de classement initial ?
L'emplacement de départ des fichiers (là où ils se situent avant déplacement)
Les raccourcis doivent pointer vers quels fichiers(ceux copiés je suppose) et où doivent-il être placés ?
Les raccourcis doivent se situer à l'emplacement où se trouvaient les fichiers avant le déplacement. De cette manière en double-cliquant sur un raccourci on ouvre le fichier multimédia situé sur le NAS sans même sans que l'utilisateur s'en rende compte.
As-tu vérifié les attributs des fichiers non déplacés ? car si ReadOnly, il faut désactiver cet attribut.
Je jetterai un œil demain (au taf), mais une fois ça fonctionnait et une autre fois non, puis de nouveau OK... Pas logique.

Essaie avec les modifications apportées au script :

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
83
84
85
86
87
88
89
90
Option Explicit' Déclaration obligatoire des variables
Dim arrExtension, objShell, objFSO, objNetwork, strDestination, strLogFile, strSource, objLogFile, objFile, strBaseName, NewFolder, objFolder
 
arrExtension = Array("tif", "jpg", "bmp", "png")
 
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
 
strDestination = "D:\temp\Test\2-Arrivee\"
strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
 
If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
strSource = "D:\temp\Test\1-Depart\"
' Efface les attributs R, S et H
objShell.Run "Cmd.exe /C Attrib " & strSource & "*.* -r -s -h /S" , 0 , False ' ##Modification ici
 
 
Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
objLogFile.WriteLine "Script started: " & Now
 
RecurseFolders strSource, strDestination
 
objLogFile.Close
MsgBox "Done"
'====================================
Private Sub RecurseFolders(srcFolder, DestFolder)
    Dim NomFichier , CheminFichier
    If objFSO.GetFolder(srcFolder).Files.Count = 0  Then 
         objLogFile.WriteLine "No file to copy from : " & srcFolder  & VbCrLf
    Else     
         objLogFile.WriteLine "Copying files from: " & srcFolder & " to " & DestFolder & VbCrLf
    End If
    For Each objFile In objFSO.GetFolder(srcFolder).Files
        If VerifExtension(objFile.Path) Then
            If objFSO.FileExists(DestFolder & "\" & objFile.Name) Then
                objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
            Else
                'strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
                strBaseName = objFSO.GetBaseName(objFile.Path)
                'On Error Resume Next ' Toujours utiliser avec précaution car cela cache des erreurs éventuelles
                NomFichier = objFile.Name
                CheminFichier = objFSO.GetFile(objFile.Path).ParentFolder  ' ##Modification ici
                objFSO.MoveFile objFile.Path, DestFolder & "\"
                If Err.Number = 0 Then
                    objLogFile.WriteLine "Copied file " & NomFichier
                    ' Création des raccourcis dans le dossier origine des fichiers
                    CreateShortcut CheminFichier & "\" & strBaseName & ".lnk", DestFolder & "\" & NomFichier ' ##Modification ici
                    objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
                Else
                    objLogFile.WriteLine "#### Error copying file " & NomFichier & ". Error " & Err.Number & ": " & Err.Description
                End If
                Err.Clear
                On Error GoTo 0
            End If
        End If
    Next
 
    ' On utilise la récursivité pour traiter tous les sous-dossiers    
 
    For Each objFolder In objFSO.GetFolder(srcFolder).SubFolders
        If  objFSO.FolderExists(DestFolder & "\" & objFolder.Name)  Then
            '### Suite à cette condition, si le dossier cible existe, les fichiers ne seront pas déplacés
            '### Ils resteront dans le dossier source
            objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
        Else
            Set NewFolder = objFSO.CreateFolder(DestFolder & "\" & objFolder.Name)
            Call RecurseFolders(objFolder.Path, NewFolder.Path)
        End If
    Next
End Sub
'==================================
Sub CreateShortcut(strName, strTarget)
    Dim objShell, objLink
    Set objShell = CreateObject("WScript.Shell")
    Set objLink = objShell.CreateShortcut(strName)
    objLink.TargetPath = strTarget
    objLink.WorkingDirectory = Left(strName, InStrRev(strName, "\")-1)
    objLink.Save
End Sub          
'==================================
Function VerifExtension(sFileName)
  Dim I
  For i = 0 To Ubound(arrExtension)
     If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
        VerifExtension = True
        Exit For
     End If
 Next
End Function

13/11/2018, 11h07
Dan25

Tip - Top !

Bravo et merci beaucoup !
Ça fonctionne impeccablement bien.
Juste un point qui coince, mais avec lequel je ferai s'il n'y a pas de solution simple :
lorsque le nom d'un fichier comporte un caractère accentué (il ne devrait pas y en avoir, mais bon...), l'accent du raccourci se retrouve entre 2 caractères. Le raccourci ne fonctionne donc pas.

Pour exemple :
Fichier origine : Râle des genets_Bronner_Small.jpg
Raccourci : Ra^le des genets_Bronner_Small.lnk

Ça risque d'être plus impactant si on a des répertoires comportant des accents, car pour tous les fichiers de ce répertoire et de ses sous-répertoires, les raccourcis ne fonctionneront pas.
Est-ce que ça pourrait être un problème d'encodage ?

En tout cas, si ça ne te dit rien, merci beaucoup pour toute l'aide apportée et le temps passé.
Dan
13/11/2018, 13h50
ProgElecT

Salut

Citation:

Envoyé par Dan25

Bravo et merci beaucoup !......... pour toute l'aide apportée et le temps passé.
Dan

tu peux remercier aussi en mettant des :plusser: à celui qui te donne le coup de main.

Pour se débarrasser des accents :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit 
Dim arrAcc, arrChar
 ' A titre d'exemple. il faut voir les autres cas(caractères majuscules)
 arrAcc  = Array("â", "à", "ä", "é", "ê", "è", "ë", "î", "ï", "ô", "ö", "û", "ü", "ù") 
 arrChar = Array("a", "a", "a", "e", "e", "e", "e", "i", "i", "o", "o", "u", "u", "u")
Function SansAccent(strIn)
   Dim I, Ret
   Ret = strIn
   For I = 0 To Ubound(arrAcc)
      Ret = Replace(Ret, arrAcc(I), arrChar(I))
   Next 
   SansAccent = Ret
End Function
' Exemple :
MsgBox SansAccent("Brûte et bête ambiguës")

De ce fait, remplace la ligne 48(pour les raccourcis) par :
CreateShortcut CheminFichier & "\" & SansAccent(strBaseName) & ".lnk", DestFolder & "\" & NomFichier