VBS: recherche par extension et copie dans un dossier

**hackoofr** · 02/01/2014, 03h37

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

Tu as le choix de protéger ton archive par mot de passe, alors, tu l'appelle comme ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

et le code complet te montre les deux à la fois

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**zollen777** · 06/01/2014, 21h29

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

**hackoofr** · 06/01/2014, 23h33

Tu remplace le mot ~~MyDocuments~~ par Desktop

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

==>

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

MyDoc=ws.SpecialFolders("Desktop")'Bureau

**zollen777** · 07/01/2014, 19h09

Envoyé par hackoofr

Tu remplace le mot ~~MyDocuments~~ par Desktop

Merci

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

VBS: recherche par extension et copie dans un dossier

VBScript

Discussions similaires

Partager

Partager