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