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
| Option Explicit
Dim source,Dest,MyCmd,Temp,Titre,MsgTitre,MsgAttente,Copyright,oExec,ws,LogTmpFile,LogFile,MyExcludeFile,Param
Dim ExtensionType, fso
Copyright = "[ XcopyScript © Hackoo Crackoo © 2014 ]"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Set bf = fso.GetFolder(MyDoc)
Temp = ws.ExpandEnvironmentStrings("%Temp%")
ExtensionType = "JPG"
source = "T:\PRO\Sauvegarde\testCompress"
Dest = "T:\PRO\Sauvegarde\testCompress\archive"
LogTmpFile = "TmpXCopyLog.txt"
LogFile = "MyXCopyLog.txt"
Param = " /D "
MyCmd = "XCopy" & " " & DblQuote(source) & " " & DblQuote(Dest) & " " & Param &" > " & LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " > " & LogFile & " & Del " & LogTmpFile & ""
Titre = "Copie de Sauvegarde " & Copyright
MsgAttente = "Copie de Sauvegarde : <font color=Yellow>" & DblQuote(source) & " vers " & DblQuote(Dest) & " </font> . . . ."
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
Call Executer(MyCmd,0)
Call FermerProgressBar()
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,Dest,"")'Sans Mot de passe
ws.run LogFile
'****************************************************************************************************
Function Executer(StrCmd,Console)
Dim ws,MyCmd,Resultat
Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
If Console = 0 Then
MyCmd = "CMD /C " & StrCmd & " "
Resultat = ws.run(MyCmd,Console,True)
If Resultat = 0 Then
Else
MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
End If
End If
'La valeur 1 pour montrer la console MS-DOS
If Console = 1 Then
MyCmd = "CMD /K " & StrCmd & " "
Resultat = ws.run(MyCmd,Console,False)
If Resultat = 0 Then
Else
MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
End If
End If
Executer = Resultat
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 500,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
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
'**********************************************************************************
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,bf, MyDoc
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
MyDoc = "T:\PRO\Sauvegarde\testFichierEfface"
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,Dest,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 & " " & "7zFM.exe") Then
sWinZipLocation = ""
ElseIf oFSO.FileExists(ProgramFiles &"\7-Zip\7zFM.exe") Then
sWinZipLocation = ProgramFiles &"\7-Zip\"
Else
Compression = "Erreur: Impossible de trouver 7zFM.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 & "7zFM.exe"" A -IBCK """ & _
Dest & """ """ & source & """",0,True
Else
'Le Commutateur -P<mot_de_passe> : Pour utiliser un mot de passe
oShell.Run """" & sWinZipLocation & "7zFM.exe"" A -IBCK -p"&Password&" """ & _
Dest & """ """ & source & """",0,True
End If
If oFSO.FileExists(Dest) Then
Compression = 1
Else
Compression = "Erreur : Création d'archives a échoué !"
MsgBox Compression,16,Compression
End If
End Function |
Partager