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 |
Partager