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 |
:salut: