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
| Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
set folder = FSO.GetFolder ("D:\test")
Set Dossiers = fso.GetFolder(folder)
Set fic = Dossiers.Files
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim folder, MyHex, MyBinary, i
Dim oShell, oApp, oFolder, oCTF, oFile
Dim oFileSys
'Boucle qui fait la comparaison avec la date du fichier créé et le nombres de jour des fichiers à zipper
For Each objFile in fic
Set f = fso.GetFile(objfile)
If DateDiff("D", objfile.DateLastModified, now) > 4 Then
MyHex = _
Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(MyHex)
MyBinary = MyBinary & Chr(MyHex(i))
Next
Set oShell = CreateObject("WScript.Shell")
Set oFileSys = CreateObject("Scripting.FileSystemObject")
'Creation du zip
Set oCTF = oFileSys.CreateTextFile(folder, True)
oCTF.Write MyBinary
oCTF.Close
Set oCTF = Nothing
Set oApp = CreateObject("Shell.Application")
Set oFolder = oApp.NameSpace(folder)
If Not oFolder Is Nothing Then _
oApp.NameSpace(folder).CopyHere oFolder.Items
wScript.Sleep 5000
Set oFile = Nothing
On Error Resume Next
Do While (oFile Is Nothing)
'Attention: provoque une erreur 70 si un des fichiers à zipper
'est toujours ouvert.
Set oFile = oFileSys.OpenTextFile(folder, ForAppending, False)
If Err.Number <> 0 Then
Err.Clear
wScript.Sleep 3000
End If
Loop
Set oFile = Nothing
Set oFileSys = Nothing
end if
next |
Partager