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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
| Option Explicit
'Variables à modifier
Const strPath = "C:\Program Files\EasyPHP5.2.10\www" 'Dossier à modifier
Dim strDate
strDate = InputBox("nombre de jours à conserver" , "le titre de la boite" , "") 'Date à modifier
msgbox "la date est ["&strDate&"]"
'------------------------------------------------
'Variables
Dim objShell, objFso, objText
Dim strListe, compteur
'Transformer la date en 01/MM/AAAA
strDate = FormatDateTime(strDate,2)
'Calculer le nombre de jours entre les 2 dates
'strDateDiff = DateDiff("d", Date , strDate)
Set objShell = CreateObject("WScript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")
'Dossier Bureau de windows + "\"
strListe = objShell.SpecialFolders("Desktop")
'Tester la fin de l'arborescence du dossier
If Right(strListe, 1) <> "\" Then strListe = strListe & "\"
'Création du fichier .txt contenant l'arborescence du répertoire à traiter vers le Bureau
Set objText = objFso.CreateTextFile(strListe & "Liste Fichiers.txt", 1, True)
'Écrire la premiere ligne de la liste
objText.WriteLine Now
objText.WriteLine ("Date d'exécution" & "|" & " Nom fichier " & Space(20) & "|" & " Chemin complet du fichier " & Space(20) & "|" & " Date de dernier accès " & Space(20) & "|" & " taille du fichier en ko " & Space(20) & "|" & " Extension " & Space(20) & "|")
'Appeler la fonction pour lister l'arborescence du dossier
FnListeDossier strPath, objText
'Écrire la dernière ligne de la liste
objText.WriteLine
objText.WriteLine "Nombre de objTexts : " & compteur &vbCrLf& Now
'Fermer le fichier .txt
objText.Close
'Supprimer les objets
Set objShell = Nothing:
Set objText = Nothing
Set objFso = Nothing
MsgBox "Script terminé"
Function FnListeDossier(strPath, objText) 'Lister l'arborescence du dossier
On Error Resume Next
Dim objFso, objFolder, objSubFolder, objSubFolderItem
Dim objFolderFind, objSubFile, objSubFileItem
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strPath) 'dossier
Set objSubFolder = objFolder.SubFolders 'sous-dossiers
For Each objSubFolderItem In objSubFolder 'Traiter chaque sous-dossiers
FnListeDossier objSubFolderItem.Path, objText 'traiter le sous-dossier
Next
Set objFolderFind = objFso.GetFolder(strPath) 'dossier
Set objSubFile = objFolderFind.Files 'objTexts
For Each objSubFileItem In objSubFile 'Traiter chaque objText du répertoire
'Vérifier si la date de modification du fichier est < à la date paramétrée
If DateDiff("d", strDate , FormatDateTime(objSubFileItem.DateLastAccessed, 2)) =< 0 Then
'Ecrire le nom du chemin dans le fichier .txt
'objText.WriteLine objSubFileItem.Name & Space(20) & "|" & Space(20) & Space(20) & objSubFileItem.path & Space(20) & "|" & Space(20) & objSubFileItem.ParentFolder & Space(20) & "|"& Space(20) & objSubFileItem.DateCreated & Space(20) & "|" & Space(20) & objSubFileItem.DateLastAccessed & Space(20) & "|" & Space(20) & objSubFileItem.DateLastModified & Space(20) & "|" & objSubFileItem.Size & Space(20) & "|" & Space(20) & objSubFileItem.Type & Space(20) & "|" & Space(20) & FSO.GetExtensionName(objSubFileItem.name) & Space(20) & "|" & Space(20) & attribut & Space(20) & "|"' & StrFileName & "|"
'objText.WriteLine objSubFileItem.Path & Space(20) & objSubFileItem.DateLastAccessed
objText.WriteLine Now & "|" & objSubFileItem.Name & "|" & Space(1) & objSubFileItem.Path & "|" & Space(1) & objSubFileItem.Size & "|" & Space(1) & objSubFileItem.Type & "|" & Space(1) & objFso.GetExtensionName(objSubFileItem.Name)& "|" & Space(1) & objFso.GetParentFolderName(objFolderFind.Name)
'Supprimer le fichier
'''''''''' objFso.DeleteFile objSubFileItem.Path
'ZIPPER LE FICHIER
compteur=compteur+1
End If
Next
'Supprimer les objets
Set objFso = Nothing
Set objFolder = Nothing
Set objSubFolder = Nothing
Set objFolderFind = Nothing
Set objSubFile = Nothing
End Function
Function Zip(sFile,sArchiveName)
Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Find Working Directory--------
aScriptFilename = Split(Wscript.ScriptFullName, "\")
sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'-------------------------------------------------------------------------------
'-------Ensure we can find Winrar.exe-------------------------------------------
If oFSO.FileExists(sWorkingDirectory & " " & "7z.exe") Then
sWinZipLocation = ""
ElseIf oFSO.FileExists("C:\Program Files\7-Zip\7z.exe") Then
sWinZipLocation = "C:\Program Files\7-Zip\"
Else
Zip = "Error: Couldn't find Winrar.EXE"
Exit Function
End If
'--------------------------------------------------------------------------------"7z.exe"" a -tzip
oShell.Run """" & sWinZipLocation & "7z.exe"" a -r """ & _
sArchiveName & """ """ & sFile & """", 0, True
If oFSO.FileExists(sArchiveName) Then
Zip = 1
Else
Zip = "Error: Archive Creation Failed."
End If
End Function
Function MoveToFirst(FolderPath)
'function need a FSO object (Set FSO=CreateObject("Scripting.FileSystemObject") )
Set Folder=FSO.GetFolder(FolderPath)
ShortName = Folder.ShortName
FilesCount = Folder.Files.Count
Do
Set Folder=FSO.GetFolder(Folder.ParentFolder)
ParentShortName = Folder.ShortName
If ParentShortName = ShortName Then FirstFolder = Folder
Loop While ParentShortName = ShortName
If Not IsEmpty(FirstFolder) Then
If FilesCount > 0 Then FSO.MoveFile FolderPath & "\*", firstfolder
FSO.GetFolder(FirstFolder & "\" & ShortName).Delete
End If
End function |
