' ***************************************
' *                                     *
' *        Réparation du registre       *
' *        et purge de infcache.1       *
' *     pour les problèmes de pilotes   *
' *          génériques sous XP         *
' *              Version 2.1            *
' *                                     *
' *      Script ~Jean-Marc~ 09/2006     *
' *         http://docxp.mvps.org       *
' *                                     *
' ***************************************

' * Version 1.1 : ajout de la configuration du service Plug and Play en automatique *
' * (réglage d'origine Windows XP)

' * Version 1.5 : ajout de la réparation de 2 clés de registre supplémentaire (KB 925196)
' * et de la création d'un point de restauration avant modifications.

' * Version 2.0 : Correction de tous les UpperFilters et LowerFilters appelant
' * des services inexistants... (09/2008)

' * Version 2.1 : Détection des filtres UpperFilters et LowerFilters dont le
' * fichier de lancement est inexistant... (05/2009)
Option Explicit

Dim FSO, Shell, WinVerXP, strPath, strOrigPath, strAppPath, Msg, windir, nominfcache
Dim objWMIService, objItem, errResults, objWMIReg, CheminSourcePath, MustDeleteFilter
Dim DescCle, SystemDrive, arrSousCle, SousCle, arrTmpLF, arrTmpUF, MustWriteFilter
Dim SystemRoot, SousCle2, arrSousCle2
Const DEVICE_DRIVER_INSTALL = 10
Const BEGIN_SYSTEM_CHANGE = 100
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ServiceKey = "SYSTEM\CurrentControlSet\Services"
Const CurrentControlSet_Control_Class = "SYSTEM\CurrentControlSet\Control\Class"
Set Shell = WScript.CreateObject("WScript.Shell")
Set FSO   = WScript.CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default")
Set objWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Set objItem = objWMIService.Get("SystemRestore")

'On error goto 0  'pour déboguage
On Error Resume Next

' Vérification : XP ou pas XP ?
WinVerXP = Shell.regread("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName")

If Not Right(WinVerXP ,2) = "XP" Then
	Msg="-----      Correctif USB     -----" & VbCrLf & VbCrLf
	Msg=Msg & "Windows XP non détecté" & VbCrLf & VbCrLf
	Msg=Msg & "( " & WinVerXP & " )" & VbCrLf & VbCrLf
	Msg=Msg & "Opération annulée" & VbCrLf
	Msg=Msg & "-----------------------------------" & VbCrLf
	MsgBox Msg,16
	WScript.quit
End If

Msg = "Correctif pour les installations de pilotes sous Windows XP"
Msg = Msg & VbCrLf & "(pilotes génériques non trouvés ou anomalies code 39)" & VbCrLf & VbCrLf

' ***********Créer un point de restauration*****************************

errResults = objItem.CreateRestorePoint _
	("Avant script de réparation drivers", _ 
	DEVICE_DRIVER_INSTALL, _ 
	BEGIN_SYSTEM_CHANGE)

If errResults = 0 Then
	Msg = Msg & "Point de restauration créé" & VbCrLf & VbCrLf
Else
	Msg = Msg & "un Point de restauration n'a pas pu être créé" & VbCrLf & VbCrLf
End If


' ***********Lire et corriger la première valeur DevicePath*************

  strPath = Shell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\DevicePath")
  If Err.Number <> 0 Then
        strPath = "%SystemRoot%\inf"
        strOrigPath = ""
  Else
        strOrigPath = strPath
  End If

 ' Vérifier DevicePath
  strAppPath = "%SystemRoot%\inf"
  strPath = AddToPath(strAppPath, strPath)
  
'Si la clé a changé, la modifier.
  If strPath <> strOrigPath Then
    Shell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\DevicePath", strPath, "REG_EXPAND_SZ"
    'MsgBox "-" & strPath & "-"  'pour déboguage
    If Err.Number <> 0 Then WScript.quit
    Msg = Msg & "DevicePath modifié :" & VbCrLf & strPath & VbCrLf
  Else
    Msg = Msg & "DevicePath correct. Aucune modification effectuée." & VbCrLf
  End If
  
  Msg = Msg & VbCrLf

' ***********Lire et corriger la deuxième valeur DriverCachePath*************

  strPath = Shell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup\DriverCachePath")
  If Err.Number <> 0 Then
        strPath = "%SystemRoot%\Driver Cache"
        strOrigPath = ""
  Else
        strOrigPath = strPath
  End If

' Vérifier DriverCachePath
  strAppPath = "%SystemRoot%\Driver Cache"
  strPath = AddToPath(strAppPath, strPath)

'Si la clé a changé, la modifier.
  If strPath <> strOrigPath Then
    Shell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup\DriverCachePath", strPath, "REG_EXPAND_SZ"
    'MsgBox "-" & strPath & "-"   'pour déboguage
    If Err.Number <> 0 Then WScript.quit
    Msg = Msg & "DriverCachePath modifié :" & VbCrLf & strPath & VbCrLf
  Else
    Msg = Msg & "DriverCachePath correct. Aucune modification effectuée." & VbCrLf
  End If

  Msg = Msg & VbCrLf

' ***********Effacer INFCACHE.1*************
  
windir=Shell.ExpandEnvironmentStrings("%windir%")
nominfcache=windir & "\inf\infcache.1"

If fso.FileExists(nominfcache) Then
        'MsgBox nominfcache  'pour déboguage
        fso.DeleteFile nominfcache, True
        If Err.Number <> 0 Then
                Msg = Msg & "INFCACHE.1 non effacé." & VbCrLf
                Msg = Msg & "Erreur N° " & Err.Number & " - " & Err.description & VbCrLf & VbCrLf
        Else
                Msg = Msg & "INFCACHE.1 effacé." & VbCrLf & VbCrLf
        End If
Else
        Msg = Msg & nominfcache & " non trouvé" & VbCrLf & VbCrLf
End If

' ******* usbstor.inf est il là ?*****************

if not fso.fileexists(windir & "\inf\usbstor.inf") then
	Msg = Msg & "Le fichier " & windir & "\inf\usbstor.inf est manquant." & vbCrLf
	CheminSourcePath = shell.regread("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup\SourcePath")
	SystemDrive = Shell.ExpandEnvironmentStrings("%SystemDrive%")
	if ucase(left(CheminSourcePath,2)) = ucase(left(SystemDrive,2)) then
		'tentative d'extraction de usbstor.in_ depuis les fichiers d'install système
		if fso.fileexists(CheminSourcePath & "i386\usbstor.in_") then
			Shell.run "expand """ & CheminSourcePath & "i386\usbstor.in_"" """ & windir & "\inf\usbstor.inf""",,true
			if fso.fileexists(windir & "\inf\usbstor.inf") then
				Msg = Msg & "USBSTOR.INF récupéré avec succès." & vbCrLf & vbCrLf
			else
				Msg = Msg & "Pas de copie trouvée, fichier NON restauré." & vbCrLf & vbCrLf
			end if
		end if
	end if
end if

' ***********Vérifier le service PnP*************
Shell.Exec("sc config PlugPlay start= auto")


' ***********Effacer 1er point de KB 925196*************

  Shell.RegDelete "HKLM\SYSTEM\CurrentControlSet\Control\Class\{4D36E980-E325-11CE-BFC1-08002BE10318}\UpperFilters"

  If Err.Number = 0 Then
        Msg = Msg & "La valeur UpperFilters était anormalement présente" & VbCrLf
		Msg = Msg & "dans {4D36E980-E325-11CE-BFC1-08002BE10318} et a été effacée" & VbCrLf & VbCrLf
  End If


' ***********Effacer 2ème point de KB 925196*************

  Shell.RegDelete "HKLM\SYSTEM\CurrentControlSet\Control\Class\{4D36E967-E325-11CE-BFC1-08002BE10318}\LowerFilters"

  If Err.Number = 0 Then
        Msg = Msg & "La valeur LowerFilters était anormalement présente" & VbCrLf
		Msg = Msg & "dans {4D36E967-E325-11CE-BFC1-08002BE10318} et a été effacée" & VbCrLf & VbCrLf
  End If

' *************************Contrôle des filtres existants ******************************
objWMIReg.EnumKey HKEY_LOCAL_MACHINE, CurrentControlSet_Control_Class, arrSousCle

'arrTmpUF = Shell.regread("HKLM\SYSTEM\CurrentControlSet\Control\Class\{4D36E96B-E325-11CE-BFC1-08002BE10318}\UpperFilters")
'arrTmpLF = Shell.regread("HKLM\SYSTEM\CurrentControlSet\Control\Class\{4D36E96B-E325-11CE-BFC1-08002BE10318}\LowerFilters")
'MsgBox ubound(arrTmpUF) & " " & ubound(arrTmpLF)

for each SousCle in arrSousCle
	
	DescCle = Shell.regread("HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\")
	
	erase arrTmpUF
	arrTmpUF = ReadFilters("UpperFilters","HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\UpperFilters")
	if IsArray(arrTmpUF) then
		VerifFiltre "UpperFilters",arrTmpUF
	end if
	
	erase arrTmpLF
	arrTmpLF = ReadFilters("LowerFilters","HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\LowerFilters")
	if IsArray(arrTmpLF) then
		VerifFiltre "LowerFilters",arrTmpLF
	end if
Next

' ***********Message final***********************
Msg = Msg & "Supprimez les périphériques USB en anomalie" & VbCrLf
Msg = Msg & "dans le gestionnaire de périphériques, puis" & VbCrLf
Msg = Msg & "redémarrez votre ordinateur" & VbCrLf & VbCrLf
Msg = Msg & "    Version 2.1      05/2009" & VbCrLf
Msg = Msg & "~Jean-Marc~  http://docxp.mvps.org/" & VbCrLf

MsgBox Msg,64

Shell.run("devmgmt.msc")

Set objItem = Nothing
Set objWMIService = Nothing
Set fso  = Nothing
Set Shell = Nothing

' ******************** Fonction de contrôle **********************

Function AddToPath ( sAdd, sPath )
  Dim CheckFlag, ArrSplit, i
  CheckFlag = False
  if left(sPath, 1) = ";" then sPath = Right(sPath, Len(sPath) - 1)
  ArrSplit = Split(sPath,";")
  sPath = ""
  For i = 0 To UBound(ArrSplit)
        if (i > 0) and (len(trim(ArrSplit(i))) > 0) then sPath = sPath & ";"
        ArrSplit(i) = Trim(ArrSplit(i))
        if ArrSplit(i) = sAdd then CheckFlag = True
        sPath = sPath & ArrSplit(i)
   Next
  If Not CheckFlag Then
    AddToPath = sPath & ";" & sAdd
  Else
    AddToPath = sPath
  End If
End Function

' *********** Vérification de l'existence d'un service *****************

Function ServiceExists(NomService)
	Dim Tmp
	on error resume next
	Tmp = Shell.RegRead("HKLM\" & ServiceKey & "\" & trim(NomService) & "\")
	If Err.Number <> 0 Then
		ServiceExists = false
		'MsgBox "HKLM\" & ServiceKey & "\" & trim(NomService) & "\" & vbCrLf & _ 
		'"n'existe pas"
	else
		ServiceExists = true
		'MsgBox "HKLM\" & ServiceKey & "\" & trim(NomService) & "\" & vbCrLf & _ 
		'"existe"
	end if
	on error goto 0
end function

' *********** Vérification de l'ImagePath d'un service *****************

Function DeleteServiceImagePathCaller(NomService, CleOrigine)
	Dim Tmp, ArrTmp
	DeleteServiceImagePathCaller = false
	on error goto 0
	SystemRoot = lcase(Shell.ExpandEnvironmentStrings("%SystemRoot%"))
	Tmp = lcase(Shell.RegRead("HKLM\" & ServiceKey & "\" & trim(NomService) & "\" & "ImagePath"))
	Tmp = lcase(Shell.ExpandEnvironmentStrings(Tmp))
	if left(Tmp,len(SystemRoot))<>SystemRoot then
		if left(Tmp,1)="""" then
			tmp = mid(Tmp,2,len(tmp)-2)
			ArrTmp = split(Tmp,"""")
			Tmp=ArrTmp(0)
		end if
		if left(Tmp,6) = "system" then
			Tmp = SystemRoot & "\" & Tmp
			ArrTmp = split(Tmp," ")
			Tmp=ArrTmp(0)
		end if
		if left(Tmp,12) = "\systemroot\" then
			Tmp = replace(Tmp, "\systemroot\", SystemRoot)
			ArrTmp = split(Tmp," ")
			Tmp=ArrTmp(0)
		end if
	else
		ArrTmp = split(Tmp," ")
		Tmp=ArrTmp(0)
	end if
	if not FSO.FileExists(Tmp) then
		if MsgBox ("Le service existe bien, mais son fichier" & vbCrLf & _
		"de lancement est absent !" & vbCrLf & vbCrLf & _ 
		"il faut soit récupérer le fichier si il s'agit d'un élément" & vbCrLf & _ 
		"indispensable au système (Google est mon ami !)," & vbCrLf & _ 
		"soit supprimer le service et son appelant" & vbCrLf & _
		"si il s'agit d'une désinstallation incomplète" & vbCrLf & vbCrLf & _
		"Fichier manquant : " & vbCrLf & Tmp & vbCrLf & vbCrLf & _
		"Service défectueux : " & vbCrLf & NomService & vbCrLf & vbCrLf & _
		"Filtre de Class appelant : " & vbCrLf & CleOrigine & vbCrLf & vbCrLf & _
		"/!\ FAUT IL SUPPRIMER " & NomService & " ET LE FILTRE ASSOCIE ?", _
		vbYesNo + vbCritical, "Fichier absent") = vbYes then
			DeleteServiceImagePathCaller = true
			objWMIReg.EnumKey HKEY_LOCAL_MACHINE, ServiceKey & "\" & trim(NomService), arrSousCle2
			for each SousCle2 in arrSousCle2
				objWMIReg.DeleteKey HKEY_LOCAL_MACHINE, ServiceKey & "\" & trim(NomService) & "\" & SousCle2 & "\"
			next
			objWMIReg.DeleteKey HKEY_LOCAL_MACHINE, ServiceKey & "\" & trim(NomService) & "\"
			'MsgBox "HKLM\" & ServiceKey & "\" & trim(NomService) & "\   Effacé"
		end if
	end if
end function

' *********** Vérification des filtres ***********************
sub VerifFiltre(LowUp, ArrTmpFilter)
	Dim Filtre, ArrTmpWrite(), Compt, TmpMsgHead, TmpMsgBody, DispMsg
	on error goto 0
	if len(trim(ArrTmpFilter(0)))=0 then exit sub
	Compt = -1
	DispMsg = false
	TmpMsgHead = DescCle & vbCrLf & SousCle & "\" & LowUp & vbCrLf
	For each Filtre in ArrTmpFilter
		if len(Filtre) > 0 then
			if not ServiceExists(Filtre) then
				if lcase(trim(Filtre)) = "partmgr" or _ 
					lcase(trim(Filtre)) = "kbdclass" or _ 
					lcase(trim(Filtre)) = "mouclass" or _ 
					lcase(trim(Filtre)) = "irenum" or _ 
					lcase(trim(Filtre)) = "volsnap" then
						MsgBox "Anomalie non corrigeable par ce script :" & vbCrLf & _ 
						"Le service " & Filtre & " est un élément essentiel de :" & vbCrLf & _ 
						DescCle & vbCrLf & "Mais il n'existe plus !!!", vbCritical
						' Pour ne pas ajouter une erreur sur une autre dans ce cas précis, on ne supprime pas la valeur
						Compt = Compt + 1
						redim preserve ArrTmpWrite(Compt)
						ArrTmpWrite(Compt) = Filtre
				else
					TmpMsgBody = TmpMsgBody & "- Appel à " & Filtre & " supprimé" & vbCrLf
					DispMsg = true
				end if
			else
				if DeleteServiceImagePathCaller(Filtre, "HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\" & LowUp) then
					TmpMsgBody = TmpMsgBody & "- Appel à et service " & Filtre & " supprimé" & vbCrLf
					DispMsg = true
				else
					Compt = Compt + 1
					redim preserve ArrTmpWrite(Compt)
					ArrTmpWrite(Compt) = Filtre
				end if
			end if
		end if
	next
	if compt = -1 then
		shell.regdelete "HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\" & LowUp
		'MsgBox "Effacement " & "HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\" & LowUp
	else
		if Compt < UBound(ArrTmpFilter) or MustWriteFilter then
			objWMIReg.SetMultiStringValue HKEY_LOCAL_MACHINE,CurrentControlSet_Control_Class & "\" & SousCle, LowUp,ArrTmpWrite
			'MsgBox "Ecriture " & "HKLM\" & CurrentControlSet_Control_Class & "\" & SousCle & "\" & LowUp
			if MustWriteFilter then
				TmpMsgBody = TmpMsgBody & "- Type de valeur erroné et corrigé." & vbCrLf
				DispMsg = true
			end if
		end if
	end if
	if DispMsg then
		Msg = Msg & TmpMsgHead & TmpMsgBody & vbCrLf
	end if
	on error resume next
end sub

' ****************** lecture des valeurs de filtre **********************
function ReadFilters(LowUp,CleRegistre)
	Dim TmpRead, TmpType, TmpArrValNames, TmpArrValTypes, TmpValName, i
	MustWriteFilter = false
	
	' Extraction du type de données
	objWMIReg.EnumValues HKEY_LOCAL_MACHINE, CurrentControlSet_Control_Class & "\" & SousCle, TmpArrValNames, TmpArrValTypes
	
	For i = 0 to UBound(TmpArrValNames)
		if lcase(TmpArrValNames(i)) = lcase(LowUp) then
			TmpType = TmpArrValTypes(i)
		end if
	next
	
	' Lecture du registre
	TmpRead = Shell.RegRead(CleRegistre)
	
	select case TmpType
		case REG_MULTI_SZ 'type de valeur correcte
			ReadFilters = TmpRead
		case REG_SZ 'type de valeur à corriger
			ReadFilters = split(TmpRead)
			MustWriteFilter = true
		case else 'Type de valeur totalement invalide, on l'efface directement
			Msg = Msg & DescCle & vbCrLf & SousCle & "\" & LowUp & vbCrLf & _ 
			"Type de valeur invalide, valeur supprimée" & vbCrLf & vbCrLf
			shell.regdelete CleRegistre
	end select
end function