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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
| On Error Resume Next
Dim Titre,Copyright,oExec,FSO,oDict,MonDossier,ObjFolder
Copyright = "( © Hackoo )"
Titre = "Liste des extensions" & " " & Copyright
MsgTitre = "Recherche et sauvegarde par extensions " & Copyright
MsgAttente = "Veuillez patienter. la recherche et la sauvegarde est en cours..."
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Set oDict = CreateObject("Scripting.Dictionary")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
basefolder = ws.SpecialFolders("desktop")'Bureau
name = "Sauvegarde"
Set bf = fso.GetFolder(basefolder)
If Not FSO.FolderExists(bf & "\" & name) Then
bf.subFolders.Add(name)
end if
MonDossier = Parcourir_Dossier()
Set ObjFolder = fso.GetFolder(MonDossier)
Call CreateProgressBar(MsgTitre,MsgAttente)'Creation de barre de progression
Call LancerProgressBar()'Lancement de la barre de progression
StartTime = Timer 'Debut du Compteur Timer
Call Pause(3)
Call Scan4Ext(MonDossier)
Call FermerProgressBar()'Fermeture de barre de progression
If Err <> 0 Then
MsgBox Err.Number & VbCrLF & Err.Description,16,Titre
End If
' Liste des clés
cles=oDict.keys
For i=0 To ubound(cles)
MyKeys = MyKeys & DblQuote(cles(i)) & VbCRLF
Next
DurationTime = FormatNumber(Timer - StartTime, 0) & " seconds." 'La duree de l'execution du script
MsgBox "Liste des " & oDict.count & " extensions trouvées dans " & VbCRLF & DblQuote(MonDossier) & VbCRLF & VbCRLF &_
MyKeys & VbCRLF & "Script terminé en "& DurationTime ,64,Titre
'****************************************************************************************************
Function Parcourir_Dossier()
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier pour la recherche " & Copyright,1,"c:\Programs")
If objFolder Is Nothing Then
Wscript.Quit
End If
NomDossier = objFolder.Title
Parcourir_Dossier = objFolder.self.path
end Function
'****************************************************************************************************
Sub Scan4Ext(sFolderName)
Set ObjFolder = fso.GetFolder(sFolderName)
For Each objFile In ObjFolder.Files
Ext = fso.GetExtensionName(ObjFile)
Ext = UCase(Ext)
If Not oDict.Exists(Ext) And Ext <> "" And Ext <> "INI" And Ext <> "DB" Then
oDict.Add Ext,True
Call CreateFolder(Ext)
End if
'WScript.Echo objFile.Path + Ext
Call CopyFile(objFile,Ext)
Next
Set colFolders = objFolder.SubFolders
For Each objSubFolder In colFolders
Set colFiles = objSubFolder.Files
For Each objFile In colFiles
Ext = fso.GetExtensionName(ObjFile)
Ext = UCase(Ext)
If Not oDict.Exists(Ext) And Ext <> "" And Ext <> "INI" And Ext <> "DB" Then
oDict.Add Ext,True
Call CreateFolder(Ext)
End if
'WScript.Echo objFile.Path + Ext
Call CopyFile(objFile,Ext)
Next
Scan4Ext(objSubFolder)
Next
End Sub
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
Sub CreateFolder(name)
Set fso = CreateObject("Scripting.FileSystemObject")
Set sho = CreateObject("Wscript.Shell")
basefolder = sho.SpecialFolders("desktop")'Creation du dossier dans le Bureau
Set bf = fso.GetFolder(basefolder &"\Sauvegarde\")
If Not FSO.FolderExists(bf & "\" & name) Then
bf.subFolders.Add(name)
Else : Exit Sub
End If
End Sub
'**********************************************************************************************
Function CopyFile(sFile,name)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Set bf = fso.GetFolder(basefolder &"\Sauvegarde\")
If FSO.FolderExists(bf & "\" & name) Then
'MsgBox "Copie de : " & Chr(34) & FSO.GetFileName(sFile) & Chr(34) & " dans " & bf & "\" & name,64,"Copie....."
'msgbox bf & "\" & name & "\" & FSO.GetFileName(sFile)
FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
End If
End Function
'****************************************************************************************************
Sub CreateProgressBar(Titre,MsgAttente)
Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
PathOutPutHTML = Temp & "\Barre.hta"
Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
fhta.WriteLine "<HTML>"
fhta.WriteLine "<HEAD>"
fhta.WriteLine "<Title> " & Titre & "</Title>"
fhta.WriteLine "<HTA:APPLICATION"
fhta.WriteLine "ICON = ""magnify.exe"" "
fhta.WriteLine "BORDER=""THIN"" "
fhta.WriteLine "INNERBORDER=""NO"" "
fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
fhta.WriteLine "SCROLL=""NO"" "
fhta.WriteLine "SYSMENU=""NO"" "
fhta.WriteLine "SELECTION=""NO"" "
fhta.WriteLine "SINGLEINSTANCE=""YES"">"
fhta.WriteLine "</HEAD>"
fhta.WriteLine "<BODY text=""white""><CENTER><DIV><SPAN ID=""ProgressBar""></SPAN>"
fhta.WriteLine "<span><marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee></span></DIV></CENTER></BODY></HTML>"
fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
fhta.WriteLine "Sub window_onload()"
fhta.WriteLine " CenterWindow 480,90"
fhta.WriteLine " Self.document.bgColor = ""DarkOrange"" "
fhta.WriteLine " End Sub"
fhta.WriteLine " Sub CenterWindow(x,y)"
fhta.WriteLine " Dim iLeft,itop"
fhta.WriteLine " window.resizeTo x,y"
fhta.WriteLine " iLeft = window.screen.availWidth/2 - x/2"
fhta.WriteLine " itop = window.screen.availHeight/2 - y/2"
fhta.WriteLine " window.moveTo ileft,itop"
fhta.WriteLine "End Sub"
fhta.WriteLine "</script>"
fhta.close
End Sub
'**********************************************************************************************
Sub LancerProgressBar()
Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub FermerProgressBar()
oExec.Terminate
End Sub
'**********************************************************************************************
Sub Pause(NSeconds)
Wscript.Sleep(NSeconds*1000)
End Sub
'********************************************************************************************** |
