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

**Dan25** · 08/11/2018, 18h36

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 :

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
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

**l_autodidacte** · 09/11/2018, 16h50

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**Dan25** · 10/11/2018, 11h20

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 :

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
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

**l_autodidacte** · 11/11/2018, 12h00

J'ai des questions sur le déplacement:

Que fait-on pour les fichiers qui ne sont pas du type multimédia ?
Que fait-on pour les fichiers qui ne seront pas déplacés ?
Idem pour les sous-dossiers ?

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

**Dan25** · 11/11/2018, 15h10

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.

**l_autodidacte** · 12/11/2018, 09h27

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

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
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

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

VBScript

Vue hybride

Discussions similaires

Partager

Partager