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