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
| Option Explicit
Const HKCU = &H80000001, REG_SZ = 1
Const sPath = "Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers"
Dim WshShell, wmiLocator, wshNetwork, wmiNameSpace, objReg, lRC
Dim Mycomputer, DestValue, fso
Set fso = CreateObject("Scripting.FileSystemObject")
Set wmiLocator = CreateObject("WbemScripting.SWbemLocator")
Set wshNetwork = CreateObject("WScript.Network")
Mycomputer = wshNetwork.ComputerName
Set wmiNameSpace = wmiLocator.ConnectServer(Mycomputer, "root\default")
Set objReg = wmiNameSpace.Get("StdRegProv")
DestValue = WScript.ScriptFullName
DestValue = Left(DestValue,Len(DestValue)-3) & "exe"
WriteCompatibleEntry HKCU, sPath
'==============================
Sub WriteCompatibleEntry(sHive, sPath)
Dim sNames, sKeyName, sValue
If Not fso.FileExists(DestValue) Then
MsgBox "Le fichier " & DestValue & " n'existe pas "
Exit Sub
End If
lRC = objReg.EnumValues(sHive, sPath, sNames, REG_SZ)
For Each sKeyName In sNames
If Err.Number <> 0 Then Exit For
If sKeyName = DestValue Then
lRC = objReg.GetStringValue(sHive , sPath, DestValue, sValue) ' La valeur existe-elle ?
If lRC = 0 Then Exit For ' Si oui, on sort de la boucle
Else ' Sinon on l'écrit avec sa donnée
lRC = objReg.SetStringValue(sHive, sPath, DestValue, "WINXP")
End If
Next
End Sub |
Partager