C'est un vbscript pour la maintenance de vos disques durs fixes et amovibles ,qui sert pour la vérification et la correction des erreurs sur ces derniers s'il y a lieu avec génération d'un rapport de scan !
un message va vous informer que "un scan planifié de ce dernier a été programmé, il sera vérifié au prochain redémarrage du système", et qu'il faut redémarrer. Alors, redémarrer et le disque sera vérifié et réparé au besoin.
Code : Tout sélectionner
Option Explicit
Dim fso,MonLecteur,MaCmd,Reboot,LogTmpFile,LogFile,ws,Temp
Dim Titre,MsgTitre,MsgAttente,Copyright,oExec,i,Question
Set fso = CreateObject("Scripting.FileSystemObject")
Copyright = "© Hackoo © 2014"
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
LogTmpFile = "MyTmpLog.txt"
LogFile = "LOG_CHKDSK.log"
If fso.FileExists(LogFile) Then fso.DeleteFile(LogFile)
Titre = "Vérification des erreurs sur les disques fixes et amovibles " & Copyright
MsgAttente = "Vérification et correction des erreurs sur les disques fixes et amovibles . . . "
Call UAC()
Call CreateProgressBar(Titre,MsgAttente)
Call LancerProgressBar()
Call Pause(2)
MonLecteur = Split(GetMyLogicDisk,":")
For i = LBound(MonLecteur) To UBound(MonLecteur) - 1
MaCmd = "echo O| CHKDSK /F "& MonLecteur(i) & ": > "& LogTmpFile &_
" & cmd /U /C Type " & LogTmpFile & " >> " & LogFile & " & Del " & LogTmpFile & ""
Call Executer(MaCmd,0,True)
Next
Call FermerProgressBar()
Question = MsgBox ("Un de vos lecteurs est verrouillé !"& VbCrLF &_
"un scan planifié de ce dernier a été programmé, il sera vérifié au prochain redémarrage du système !"& VbCrLF &_
"Voulez-vous redémarrer maintenant ?" ,VBYesNO+VbQuestion,Titre)
If Question = VbYes then
Reboot = "Shutdown.exe /r /t 120 /c "& DblQuote("Enregistrez vos documents - Redémarrage du PC dans 2 minutes") &""
Call Executer(Reboot,0,False)
ws.run LogFile
else
ws.run LogFile
End if
'**************************************************************************************************************
Function Executer(StrCmd,Console,bWaitOnReturn)
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,bWaitOnReturn)
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,bWaitOnReturn)
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
'***********************************************************************************************************
Function GetMyLogicDisk()
Dim objWMIService,objDisk,MyDevice
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
For Each objDisk in objWMIService.ExecQuery("Select * from Win32_LogicalDisk")
If objDisk.DriveType = "2" OR objDisk.DriveType = "3" Then
MyDevice = MyDevice & objDisk.DeviceID
End If
Next
GetMyLogicDisk = MyDevice
End Function
'***********************************************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(strIn)
DblQuote = Chr(34) & strIn & Chr(34)
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>"
fhta.WriteLine "<marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & MsgAttente &"</font></marquee>"
fhta.WriteLine "<img src=""data:image/gif;base64,R0lGODlhgAAPAPIAAP////INPvvI0/q1xPVLb/INPgAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh/hpDcmVhdGVkIHdpdGggYWpheGxvYWQuaW5mbwAh+QQJCgAAACwAAAAAgAAPAAAD5wiyC/6sPRfFpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwDkJEDE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/4ixgeloM5erDHonOWBFFlJoxiiTFtqWwa/Jhx/86nKdc7vuJ6mxaABbUaUTvljBo++pxO5nFQFxMY1aW12pV+q9yYGk6NlW5bAPQuh7yl6Hg/TLeu2fssf7/19Zn9meYFpd3J1bnCMiY0RhYCSgoaIdoqDhxoFnJ0FFAOhogOgo6GlpqijqqKspw+mrw6xpLCxrrWzsZ6duL62qcCrwq3EsgC0v7rBy8PNorycysi3xrnUzNjO2sXPx8nW07TRn+Hm3tfg6OLV6+fc37vR7Nnq8Ont9/Tb9v3yvPu66Xvnr16+gvwO3gKIIdszDw65Qdz2sCFFiRYFVmQFIAEBACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9J2qd1AoM9MYeF4KaWJKWmaJXxEyulI3zWa/39Xh6/vkT3q/DC/JiBFjMSCM2hUybUwrdFa3Pqw+pdEVxU3AViKVqwz30cKzmQpZl8ZlNn9uzeLPH7eCrv2l1eXKDgXd6Gn5+goiEjYaFa4eOFopwZJh/cZCPkpGAnhoFo6QFE6WkEwOrrAOqrauvsLKttKy2sQ+wuQ67rrq7uAOoo6fEwsjAs8q1zLfOvAC+yb3B0MPHD8Sm19TS1tXL4c3jz+XR093X28ao3unnv/Hv4N/i9uT45vqr7NrZ89QFHMhPXkF69+AV9OeA4UGBDwkqnFiPYsJg7jBktMXhD165jvk+YvCoD+Q+kRwTAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJdCLnC/S+nsCFo1dq5zeRoFlJ1Du91hOq3b3qNo/5OdZPGDT1QrSZDLIcGp2o47MYheJuImmVer0lmRVlWNslYndm4Jmctba5gm9sPI+gp2v3fZuH78t4Xk0Kg3J+bH9vfYtqjWlIhZF0h3qIlpWYlJpYhp2DjI+BoXyOoqYaBamqBROrqq2urA8DtLUDE7a1uLm3s7y7ucC2wrq+wca2sbIOyrCuxLTQvQ680wDV0tnIxdS/27TND+HMsdrdx+fD39bY6+bX3um14wD09O3y0e77+ezx8OgAqutnr5w4g/3e4RPIjaG+hPwc+stV8NlBixAzSlT4bxqhx46/MF5MxUGkPA4BT15IyRDlwG0uG55MAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPECwbnu3gUKH1h2ZziNKVlJWDW9FvSuI/nkusPjrF0OaBIGfTna7GaTNTPGIvK4GUZRV1WV+ssKlE/G0hmDTqVbdPeMZWvX6XacAy6LwzAF092b9+GAVnxEcjx1emSIZop3g16Eb4J+kH+ShnuMeYeHgVyWn56hakmYm6WYnaOihaCqrh0FsbIFE7Oytba0D7m6DgO/wAMTwcDDxMIPx8i+x8bEzsHQwLy4ttWz17fJzdvP3dHfxeG/0uTjywDK1Lu52bHuvenczN704Pbi+Ob66MrlA+scBAQwcKC/c/8SIlzI71/BduysRcTGUF49i/cw5tO4jytjv3keH0oUCJHkSI8KG1Y8qLIlypMm312ASZCiNA0X8eHMqPNCTo07iyUAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8hffaB3ZiWJKfmaJgJWHV5FqQK9uPuDr6yPeTniAIzBV/utktVmPCOE8GUTc9Ia0AYXWXPXaTuOhr4yRDzVIjVY3VsrnuK7ynbJ7rYlp+6/u2vXF+c2tyHnhoY4eKYYJ9gY+AkYSNAotllneMkJObf5ySIphpe3ajiHqUfENvjqCDniIFsrMFE7Sztre1D7q7Dr0TA8LDA8HEwsbHycTLw83ID8fCwLy6ubfXtNm40dLPxd3K4czjzuXQDtID1L/W1djv2vHc6d7n4PXi+eT75v3oANSxAzCwoLt28P7hC2hP4beH974ZTEjwYEWKA9VBdBixLSNHhRPlIRR5kWTGhgz1peS30l9LgBojUhzpa56GmSVr9tOgcueFni15styZAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKsWIPiFwhia4kWWKrl5UGXFMFa/nJ0Da+r0rF9vAiQOH0DZTMeYKJ0y6O2JPApXRmxVe3VtSVSmRLzENWm7MM+65ra93dNXHgep71H0mSzdFec+b3SCgX91AnhTeXx6Y2aOhoRBkllwlICIi49liWmaapGhbKJuSZ+niqmeN6SWrYOvIAWztAUTtbS3uLYPu7wOvrq4EwPFxgPEx8XJyszHzsbQxcG9u8K117nVw9vYD8rL3+DSyOLN5s/oxtTA1t3a7dzx3vPwAODlDvjk/Orh+uDYARBI0F29WdkQ+st3b9zCfgDPRTxWUN5AgxctVqTXUDNix3QToz0cGXIaxo32UCo8+OujyJIM95F0+Y8mMov1NODMuPKdTo4hNXgMemGoS6HPEgAAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9pcgitpIhmaZouMGYq/LwbPMTJVE34/Z9j7BJCgE+obBnAWSwzWZMaUz+nQQkUfjyhrEmqTQGnins5XH5iU3u94Crtpfe4SuV9NT8R0Nn5/8RYBedHuFVId6iDyCcX9vXY2Bjz52imeGiZmLk259nHKfjkSVmpeWanhhm56skIyABbGyBROzsrW2tA+5ug68uLbAsxMDxcYDxMfFycrMx87Gv7u5wrfTwdfD2da+1A/Ky9/g0OEO4MjiytLd2Oza7twA6/Le8LHk6Obj6c/8xvjzAtaj147gO4Px5p3Dx9BfOQDnBBaUeJBiwoELHeaDuE8uXzONFu9tE2mvF0KSJ00q7Mjxo8d+L/9pRKihILyaB29esEnzgkt/Gn7GDPosAQAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTcJJKmV5oUKJ7qBGPyKMzNVUkzjFoSPK9YjKHQQgSve7eeTKZs7ps4GpRqDSNcQu01Kazlwbxp+ksfipezY1V5X2ZI5XS1/5/j7l/12A/h/QXlOeoSGUYdWgXBtJXEpfXKFiJSKg5V2a1yRkIt+RJeWk6KJmZhogKmbniUFrq8FE7CvsrOxD7a3Drm1s72wv7QPA8TFAxPGxcjJx8PMvLi2wa7TugDQu9LRvtvAzsnL4N/G4cbY19rZ3Ore7MLu1N3v6OsAzM0O9+XK48Xn/+notRM4D2C9c/r6Edu3UOEAgwMhFgwoMR48awnzMWOIzyfeM4ogD4aMOHJivYwexWlUmZJcPXcaXhKMORDmBZkyWa5suE8DuAQAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9h03gZNgmtqJXqqwka8YM2NlQXYN2ze254/WyiF0BYU8nSyJ+zmXQB8UViwJrS2mlNacerlbSbg3E5fJ1WMLq9KeleB3N+6uR+XEq1rFPtmfdHd/X2aDcWl5a3t+go2AhY6EZIZmiACWRZSTkYGPm55wlXqJfIsmBaipBROqqaytqw+wsQ6zr623qrmusrATA8DBA7/CwMTFtr24yrrMvLW+zqi709K0AMkOxcYP28Pd29nY0dDL5c3nz+Pm6+jt6uLex8LzweL35O/V6fv61/js4m2rx01buHwA3SWEh7BhwHzywBUjOGBhP4v/HCrUyJAbXUSDEyXSY5dOA8l3Jt2VvHCypUoAIetpmJgAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8q/YdN4Gj+AgoqqVqJWHkFrsW5Jbzbee8yaaTH4qGMxF3Rh0s2WMUnUioQygICo9LqYzJ1WK3XiX4Na5Nhdbfdy1mN8nuLlxMTbPi4be5/Jzr+3tfdSdXbYZ/UX5ygYeLdkCEao15jomMiFmKlFqDZz8FoKEFE6KhpKWjD6ipDqunpa+isaaqqLOgEwO6uwO5vLqutbDCssS0rbbGuMqsAMHIw9DFDr+6vr/PzsnSx9rR3tPg3dnk2+LL1NXXvOXf7eHv4+bx6OfN1b0P+PTN/Lf98wK6ExgO37pd/pj9W6iwIbd6CdP9OmjtGzcNFsVhDHfxDELGjxw1Xpg4kheABAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTeBowiZjqCqG9malYS5sXXScYnvcP6swJqux2MMjTeiEjlbyl5MAHAlTEarzasv+8RCu9uvjTuWTgXedFhdBLfLbGf5jF7b30e3PA+/739ncVp4VnqDf2R8ioBTgoaPfYSJhZGIYhN0BZqbBROcm56fnQ+iow6loZ+pnKugpKKtmrGmAAO2twOor6q7rL2up7C/ssO0usG8yL7KwLW4tscA0dPCzMTWxtXS2tTJ297P0Nzj3t3L3+fmzerX6M3hueTp8uv07ezZ5fa08Piz/8UAYhPo7t6+CfDcafDGbOG5hhcYKoz4cGIrh80cPAOQAAAh+QQJCgAAACwAAAAAgAAPAAAD5wi0C/6sPRfJpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwFkJEFE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAA7AAAAAAAAAAAA"" />"
fhta.WriteLine "</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 480,110"
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 UAC()
'Run this subroutine FIRST THING on any script that may require admin
'priveleges. It will generate a "User Access Control" prompt on Vista
'or generate a "Run As" prompt for admin priveleges on 2K/XP (if the
'2K/XP user isn't an admin). It will do nothing on Win9x systems or
'on Win2K/XP systems with a logged-in admin.
Const FOR_WRITING = 2
Const TEMP_FOLDER = 2
Dim ws, fs, ts, wmi, col, obj
Dim strData, strUacFile, strArg, strArgs, strOsVersion, strUserName, strGroup, strMember
Dim lngArg, lngOsVersion
Dim blnIsAdmin, blnHasAdmins
'See if we can create needed objects
On Error Resume Next
Err.Clear
Set fs = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
Set wmi = GetObject("winmgmts:\\.\root\CIMV2")
If Err.Number <> 0 Then Exit Sub 'Reasonable assumption it's Win9x?
On Error Goto 0
'Define the name of the special script that will re-launch this one for UAC if needed.
'Can't use %TEMP% or other per-user folder, can't use script folder because it might be
'in protected area.
strUacFile = ""
If strUacFile = "" Then
'First try to use "shared docs" because everyone can get to it.
strUacFile = ws.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Common Documents")
If strUacFile <> "" Then
If fs.FolderExists(strUacFile) Then
strUacFile = fs.BuildPath(strUacFile, "~" & fs.GetBaseName(WScript.ScriptName) & ".vbs")
Else
strUacFile = ""
End If
End If
End If
If strUacFile = "" Then
'Last choice is the drive root. At least we know it exists!
strUacFile = fs.BuildPath(fs.GetDriveName(WScript.Path) & "\", "~" & fs.GetBaseName(WScript.ScriptName) & ".vbs")
End If
'If the UAC script exists, we can assume it launched this one! It should be deleted.
If fs.FileExists(strUacFile) Then
fs.DeleteFile strUacFile
Exit Sub
End If
'Find the Operating System major version
Set col = wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48)
strOsVersion = "0.0"
For Each obj In col : strOsVersion = obj.Version : Next
If Instr(strOsVersion, ".") Then strOsVersion = Left(strOsVersion, Instr(strOsVersion, ".") - 1)
lngOsVersion = CLng(strOsVersion)
'If the OS is less than W2K, everybody is an admin and no UAC prompt is needed
If lngOsVersion < 5 Then Exit Sub
'Find the user name (needed to see if the user is an admin)
Set col = wmi.ExecQuery("SELECT * FROM Win32_ComputerSystem", "WQL", 48)
strUserName = ""
For Each obj In col : strUserName = obj.UserName : Next
If Instr(strUserName, "\") Then strUserName = Mid(strUserName, Instr(strUserName, "\") + 1)
'See if the user is an admin
blnIsAdmin = False
blnHasAdmins = False
Set col = wmi.ExecQuery("SELECT * FROM Win32_GroupUser", "WQL", 48)
For Each obj In col
strGroup = obj.GroupComponent
strGroup = Split(strGroup, "=")
If strGroup(UBound(strGroup)) = """Administrateurs""" Then
blnHasAdmins = True
strMember = obj.PartComponent
strMember = Split(strMember, "=")
If strMember(UBound(strMember)) = """" & strUserName & """" Then
blnIsAdmin = True
End If
End If
Next
If blnHasAdmins = False Then blnIsAdmin = True 'If no admin group then everybody is an admin?
'Final test. No UAC prompt is needed if user is admin on something less than Vista
If ((lngOsVersion < 6) And (blnIsAdmin)) Then Exit Sub
'This is definitely a directly-run script. We need to re-launch it to get a UAC.
'First collect any arguments the script has so we can re-launch it exactly the same.
For lngArg = 0 To WScript.Arguments.Count - 1
If strArgs <> "" Then strArgs = strArgs & " "
strArg = WScript.Arguments(lngArg)
If ((InStr(strArg, " ") <> 0) Or (InStr(strArg, vbTab) <> 0)) Then
strArg = """" & """" & strArg & """" & """"
End If
strArgs = strArgs & strArg
Next
'Now build the actual command that will re-launch the script with a UAC prompt
strData = "CreateObject(""Shell.Application"").ShellExecute "
strData = strData & """" & """" & """" & Wscript.FullName & """" & """" & """"
strData = strData & ", "
strData = strData & """" & """" & """" & WScript.ScriptFullName & """" & """"
If strArgs = "" Then
strData = strData & """, "
Else
strData = strData & " " & strArgs & """, "
End If
strData = strData & """" & """" & """" & fs.GetParentFolderName(WScript.ScriptFullName) & """" & """" & """"
strData = strData & ", "
strData = strData & """runas"""
strData = strData & ", 1"
'Save the UAC command in a separate script
Set ts = fs.OpenTextFile(strUacFile, FOR_WRITING, True)
ts.Write strData
ts.Close
'Show a message
'Wscript.Echo "This script will need administrative priveleges."
'Launch the UAC script
ws.Run "wscript.exe" & " """ & strUacFile & """", 1, False
'We MUST exit at this point and let the UAC script re-launch us.
WScript.Quit
End Sub
'**********************************************************************************************