search registry for value if match found delete parent key - vbscript

I need help with a script that would traverse through the registry for a particular value and once match is found delete the parent key. I have found a code but it does not work. I suspect that is in not traversing through the registry key for match.
Option Explicit
Const HKEY_LOCAL_MACHINE = &H80000002
Const cRegKeyStartingPath = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
Const cRegValueToFind = "Ossec HIDS"
Const cRegDataToMatch = "DisplayName"
Dim oReg, subkey, arrSubKeys, sCurrentKey, sCurrentValuePath, iDeletedCount
iDeletedCount = 0
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
oReg.EnumKey HKEY_LOCAL_MACHINE, cRegKeyStartingPath, arrSubKeys
On Error Resume Next
For Each subkey In arrSubKeys
If Err.Number = 0 Then 'in case the collection is empty
sCurrentKey = "HKLM\" & cRegKeyStartingPath & subkey
sCurrentValuePath = sCurrentKey & "\" & cRegValueToFind
If customRegRead(sCurrentValuePath) = cRegDataToMatch Then
WScript.Echo "Going to delete "&sCurrentKey
DeleteRegKey sCurrentKey&"\"
iDeletedCount = iDeletedCount + 1
End If
Else
iDeletedCount = -1
End If
Next
Select Case iDeletedCount
Case 0
WScript.Echo "No matching keys found"
Case -1
WScript.Echo "No subkeys found below HKLM\"&cRegKeyStartingPath
Case Else
WScript.Echo "Deleted " & iDeletedCount & " keys"
End Select
Function customRegRead(sRegValue)
Dim oShell
Dim sRegReturn
Set oShell = CreateObject("WScript.Shell")
On Error Resume Next
Err.Clear
sRegReturn = oShell.RegRead(sRegValue)
If Err.Number<>0 Then
customRegRead = "Failed To Read Value"
Else
customRegRead = sRegReturn
End If
End Function
Sub DeleteRegKey(sKey)
Dim oShell
Set oShell = CreateObject("Wscript.Shell")
oShell.RegDelete sKey
End Sub
If there is something cleaner/better please advise.

I'd suggest to remove all occurrences of On Error Resume Next and stick with WMI methods. Also your current code doesn't use recursion, so you can only find values in immediate subkeys of cRegKeyStartingPath. You'll need recursion for traversing a tree of arbitrary depth.
Use EnumValues to enumerate the values of a given key:
rc = reg.EnumValues(HKLM, key, names, types)
The method returns 0 on success, so you can check for errors by evaluating the return code. After the call finishes the variable names contains an array with the names of the values in key, or Null if the key did not contain any values (short of the default value, that is). So the code for checking if a particular value exists in a given key might look like this:
reg.EnumValues HKLM, key, names, types
If Not IsNull(names) Then
For Each name In names
If name = "foo" Then
reg.GetStringValue HKLM, key, name, data
If data = "bar" Then
'delete key here
Exit For
End If
End If
Next
End If
You can traverse the registry by enumerating the subkeys of a given key via EnumKey and recursing into those subkeys:
Sub TraverseRegistry(root, key)
reg.EnumKey root, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
TraverseRegistry root, key & "\" & sk
Next
End If
End Sub
To delete a key use the DeleteKey method. The information which key must be deleted is something you already have: it's the value of the variable key from the value enumeration routine when found is true. However, you can't delete a key that has subkeys, so you must delete those first. Something for which you can re-use the traversal routine from above:
Sub DelKey(root, key)
reg.EnumKey root, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
DelKey root, key & "\" & sk 'delete subkeys first
Next
End If
'at this point all subkeys have already been deleted, so we can
'now delete the parent key
reg.DeleteKey root, key
End Sub
Put everything together and you get something like this:
Const HKLM = &h80000002
Const StartKey = "SOFTWARE\Wow...ion\Uninstall"
Const SearchValue = "DisplayName"
Const MatchData = "Ossec HIDS"
Set reg = GetObject("winmgmts://./root/default:StdRegProv")
FindAndDeleteKey HKLM, StartKey, SearchValue, MatchData
Sub FindAndDeleteKey(root, key, value, data)
reg.EnumValues HKLM, key, names, types
If Not IsNull(names) Then
For Each name In names
If name = value Then
reg.GetStringValue HKLM, key, name, regdata
If regdata = data Then
DelKey root, key
Exit Sub
End If
End If
Next
End If
'value not found in current key => continue search in subkeys
reg.EnumKey root, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
FindAndDeleteKey root, key & "\" & sk, value, data
Next
End If
End Sub
Sub DelKey(root, key)
reg.EnumKey root, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
DelKey root, key & "\" & sk 'delete subkeys first
Next
End If
'at this point all subkeys have already been deleted, so we can
'now delete the parent key
reg.DeleteKey root, key
End Sub
Since you're looking for a particular value with particular data you could even simplify FindAndDeleteKey() to this:
Sub FindAndDeleteKey(key)
'Try to read the value directly. If the value doesn't exist this will
'simply return a non-zero return code and set data to Null.
reg.GetStringValue HKLM, key, SearchValue, data
If Not IsNull(data) Then
'value does exist
If data = MatchData Then
DelKey HKLM, key
Exit Sub
End If
End If
'value not found in current key => continue search in subkeys
reg.EnumKey HKLM, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
FindAndDeleteKey key & "\" & sk
Next
End If
End Sub
Edit: Below is a version that generates some debug output. Run it in a command prompt via cscript debug_sample.vbs. Note that since you want to delete stuff in HKLM you must run the script "as Administrator" when UAC is enabled.
Const HKLM = &h80000002
Const StartKey = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
Const SearchValue = "DisplayName"
Const MatchData = "Ossec HIDS"
Set reg = GetObject("winmgmts://./root/default:StdRegProv")
FindAndDeleteKey StartKey
Sub FindAndDeleteKey(key)
WScript.Echo "[HKLM\" & key & "]"
rc = reg.GetStringValue(HKLM, key, SearchValue, data)
If Not IsNull(data) Then
WScript.Echo """" & SearchValue & """=""" & data & """"
If data = MatchData Then
DelKey HKLM, key
Exit Sub
End If
Else
WScript.Echo "'" & SearchValue & "' not found in [HKLM\" & key & "], rc=" & rc
End If
reg.EnumKey HKLM, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
FindAndDeleteKey key & "\" & sk
Next
End If
End Sub
Sub DelKey(root, key)
reg.EnumKey root, key, subkeys
If Not IsNull(subkeys) Then
For Each sk In subkeys
DelKey root, key & "\" & sk
Next
End If
rc = reg.DeleteKey(root, key)
WScript.Echo "Deleting [HKLM\" & key & "], rc=" & rc
End Sub
I was able to reproduce a return code 6 (handle is invalid) with an invalid hDefKey value, e.g. &h8000002 (only 7 digits) or h80000002 (missing ampersand).

Related

Invalid Parameter error when setting a registry multiStringValue using vbscript

This is in reference to an existing question I previously asked but same conditions are not working when doing another sub. All variables below are defined correct and as strings. I am getting error when setting values on this line:
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
The code is below;
return = objReg.getMultiStringValue (HKCU,IE_Main,mStrSecStartPages,multiStringValues)
'If values found in Secondary Start Pages
If return=0 Then
ReDim allURLs(0)
'Read all values and only store non intranet values to array
For Each itemname In multiStringValues
If itemname <> strFunctionIntranet1 And itemname <> strFunctionIntranet2 And itemname <> strFunctionIntranet3 And itemname <> strFunctionIntranet4 Then
ReDim Preserve allURLs(UBound(allURLs)+1)
allURLs(UBound(allURLs)) = itemname
End If
Next
'Remove current key holding existing values
objReg.DeleteValue HKCU,IE_Main,mStrSecStartPages
'Set new values based on values read and user's intranet
if UBound(allURLs)>=0 Then
wscript.echo "in setting"
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
End If
wscript.echo "out setting"
End If
Problem is even if there isn't any values in the REG_MULTI_SZ value you will still get an empty Array returned, which means when you then loop through the array and dynamically expand it using
ReDim Preserve allURLs(UBound(allURLs)+1)
You will always have a blank element in the first position in the array which when passed to
objReg.setMultiStringValue HKCU,IE_Main,mStrSecStartPages,allURLs
if it isn't the only element you will get
SWbemObjectEx: Invalid parameter
Here is some testing I did to prove this
Option Explicit
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oReg
Dim strKeyPath, strValueName, arrStringValues
Dim strComputer: strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Internet Explorer\Main"
strValueName = "Default_Secondary_Page_URL"
Dim rtn
rtn = oReg.GetMultiStringValue(HKEY_LOCAL_MACHINE, strKeyPath, strValueName, arrStringValues)
Dim i
If rtn = 0 Then
If IsArray(arrStringValues) Then
For i = 0 To UBound(arrStringValues)
WScript.Echo "arrStringValues(" & i & ") = " & arrStringValues(i)
Next
Else
WScript.Echo "Not Array"
End If
Else
WScript.Echo "Failed to GetMultiStringValue - Return (" & rtn & ")"
End If
rtn = oReg.SetMultiStringValue(HKEY_LOCAL_MACHINE,strKeyPath,strValueName,arrStringValues)
WScript.Echo "SetMultiStringValue - Return (" & rtn & ")"
Output:
arrStringValues(0) =
SetMultiStringValue - Return (0)
Adding the following line to create two blank elements under the IsArray() check
ReDim Preserve arrStringValues(UBound(arrStringValues) + 1)
Output:
arrStringValues(0) =
arrStringValues(1) =
test36.vbs(31, 1) SWbemObjectEx: Invalid parameter
So SetMultiSringValue() will accept an Array that contains an empty element if it is the only element in the array, the minute you try to add more you will get the error as described above.
In relation to the original code
To stop creating the extra blank element at the beginning you could switch to using a For instead of a For Each that way you can tell the loop to only call
ReDim Preserve allURLs(UBound(allURLs)+1)
when the index of the Array is greater then 0
For i = 0 To UBound(multiStringValues)
itemname = multiStringValues(i)
If itemname <> strFunctionIntranet1 And itemname <> strFunctionIntranet2 And itemname <> strFunctionIntranet3 And itemname <> strFunctionIntranet4 Then
'Only expand if we have more then 1 value in multiStringValues
If i > 0 Then ReDim Preserve allURLs(UBound(allURLs)+1)
allURLs(UBound(allURLs)) = itemname
End If
Next
You can do this with a For Each of course but you would have to track the Array index manually using another variable, which in my opinion when you have For already seems pointless.

add multiple multi string values to registry using array

Code is cleaned and changed from previous post since old logics had various errors that have been corrected and narrowed down to one error in one condition that I cant find an answer to. Currently getting error when my url is being read as only value and throwing Subscript Out of range error even though array is initialized. Other conditions when user has preset items or no key at all works perfectly. Thanks.
option explicit
'on error resume next
Dim ObjName,oADSysInfo,strComputer
Dim objReg,IE_Main,mstrValName,strFunctionIntranet,strNYHomepage,multiStringValues(),allURLs(),itemname,a,return
Set oADSysInfo = CreateObject("ADSystemInfo")
Set ObjName = GetObject("LDAP://" & oADSysInfo.UserName)
strComputer = "."
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
Const HKCU = &H80000001
IE_Main = "Software\Microsoft\Internet Explorer\Main"
mstrValName = "Secondary Start Pages"
strNYHomepage = "http://www.google.com"
strFunctionIntranet = "www.mycompany.com"
SetHomePage
Sub SetHomepage
objReg.setStringValue HKCU,IE_Main,"Start Page",strNYHomepage
'Reading MultiStringValue of "Secondary Start Pages" for HKCU and continuing if it has something preset.
return = objReg.getMultiStringValue (HKCU,IE_Main,mstrValName,multiStringValues)
If return=0 Then
a=0
'Reading all items currently set to make sure users retain their existing URLs.
For Each itemname In multiStringValues
'Only continue if any of the existing URLs DO NOT MATCH what we are enforcing as the URL.
If itemname <> strFunctionIntranet Then
WScript.Echo itemname
WScript.Echo "itemname is NOT equal intranet"
a = a + 1
ReDim Preserve allURLs(a)
allURLs(a) = itemname
'a = a + 1
End If
Next
objReg.DeleteValue HKCU,IE_Main,mstrValName
'Enforce our URL to always be the first item.
allURLs(0)=strFunctionIntranet
'Set the new MultiStringValue registry key back.
objReg.setMultiStringValue HKCU,IE_Main,mstrValName,allURLs
WScript.echo "finished setting all secondary tabs... "
Else
strFunctionIntranet = Array(strFunctionIntranet)
objReg.setMultiStringValue HKCU,IE_Main,mstrValName,strFunctionIntranet
End If
End Sub
Wscript.Quit
Your array contains an empty element, because you create it one field too big.
Change this line:
ReDim Preserve allURLs(a+1)
into this:
ReDim Preserve allURLs(a)

How to iterate registry from the root?

I would like to search all the registry (HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS and all of the subkeys) for a specific value and if there is a match I would like to delete this entry. Is there a way to do this? I found a sample like below but it is not iterating all the registry.
Best Regards and thanks in advance.
Const HKCU = &H80000001
Const HKLM = &H80000002
Const HKU = &H80000003
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
valueToDelete = "Alex De Souza"
Set reg = GetObject("winmgmts://./root/default:StdRegProv")
Sub DeleteFromRegistry(hive, key, searchValue)
'enumerate values and delete matching ones
rc = reg.EnumValues(hive, key, values, types)
If Not IsNull(values) Then
For i = LBound(values) To UBound(values)
strValueName = values(i)
Select Case types(i)
' Show a REG_SZ value
'
Case REG_SZ
reg.GetStringValue hive, key, strValueName, strValue
If InStr(strValue, searchValue) > 0 Then
wscript.echo "Found " & key & ": "& strValueName & " (REG_SZ) = " & strValue
rc = reg.DeleteValue(hive, key, strValue)
End If
' Show a REG_EXPAND_SZ value
'
Case REG_EXPAND_SZ
reg.GetExpandedStringValue hive, key, strValueName, strValue
If InStr(strValue, searchValue) > 0 Then
wscript.echo "Found "& key & ": " & strValueName & " REG_EXPAND_SZ) = " & strValue
rc = reg.DeleteValue(hive, key, strValue)
End If
' Show a REG_DWORD value
'
Case REG_DWORD
reg.GetDWORDValue hive, key, strValueName, uValue
If InStr(strValue, searchValue) > 0 Then
wscript.echo "Found "& key & ": " & strValueName & " (REG_DWORD) = " & strValue
rc = reg.DeleteValue(hive, key, strValue)
End If
End Select
Next
End If
'enumerate subkeys and recurse
rc = reg.EnumKey(hive, key, subkeys)
If Not IsNull(subkeys) Then
For Each sk In subkeys
If key = "" Then
path = sk
Else
path = key & "\" & sk
End If
DeleteFromRegistry hive, path, searchValue
Next
End If
End Sub
'iterate over hives (HKCR can be ignored, because it's just a combining view
'on 2 subkeys of HKLM and HKCU)
For Each hive In Array(HKCU, HKLM, HKU)
DeleteFromRegistry hive, "", valueToDelete
Next
You need a recursive procedure for this.
Const HKCU = &H80000001
Const HKLM = &H80000002
Const HKU = &H80000003
valueToDelete = "..."
Set reg = GetObject("winmgmts://./root/default:StdRegProv")
Sub DeleteFromRegistry(hive, key, searchValue)
'enumerate values and delete matching ones
rc = reg.EnumValues(hive, key, values, types)
If Not IsNull(values) Then
For Each val In values
If val = searchValue Then rc = reg.DeleteValue(hive, key, val)
Next
End If
'enumerate subkeys and recurse
rc = reg.EnumKey(hive, key, subkeys)
If Not IsNull(subkeys) Then
For Each sk In subkeys
If key = "" Then
path = sk
Else
path = key & "\" & sk
End If
DeleteFromRegistry hive, path, valueToDelete
Next
End If
End Sub
'iterate over hives (HKCR can be ignored, because it's just a combining view
'on 2 subkeys of HKLM and HKCU)
For Each hive In Array(HKCU, HKLM, HKU)
DeleteFromRegistry hive, "", valueToDelete
Next

Check if registry key exists using VBScript

I thought this would be easy, but apparently nobody does it...
I'm trying to see if a registry key exists. I don't care if there are any values inside of it such as (Default).
This is what I've been trying.
Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
objRegistry.GetStringValue &H80000003,".DEFAULT\Network","",regValue
If IsEmpty(regValue) Then
Wscript.Echo "The registry key does not exist."
Else
Wscript.Echo "The registry key exists."
End If
I only want to know if HKEY_USERES\.DEFAULT\.Network exists. Anything I find when searching mostly seems to discuss manipulating them and pretty much assumes the key does exists since it's magically created if it doesn't.
I found the solution.
dim bExists
ssig="Unable to open registry key"
set wshShell= Wscript.CreateObject("WScript.Shell")
strKey = "HKEY_USERS\.Default\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Digest\"
on error resume next
present = WshShell.RegRead(strKey)
if err.number<>0 then
if right(strKey,1)="\" then 'strKey is a registry key
if instr(1,err.description,ssig,1)<>0 then
bExists=true
else
bExists=false
end if
else 'strKey is a registry valuename
bExists=false
end if
err.clear
else
bExists=true
end if
on error goto 0
if bExists=vbFalse then
wscript.echo strKey & " does not exist."
else
wscript.echo strKey & " exists."
end if
The second of the two methods here does what you're wanting. I've just used it (after finding no success in this thread) and it's worked for me.
http://yorch.org/2011/10/two-ways-to-check-if-a-registry-key-exists-using-vbscript/
The code:
Const HKCR = &H80000000 'HKEY_CLASSES_ROOT
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
Const HKUS = &H80000003 'HKEY_USERS
Const HKCC = &H80000005 'HKEY_CURRENT_CONFIG
Function KeyExists(Key, KeyPath)
Dim oReg: Set oReg = GetObject("winmgmts:!root/default:StdRegProv")
If oReg.EnumKey(Key, KeyPath, arrSubKeys) = 0 Then
KeyExists = True
Else
KeyExists = False
End If
End Function
Simplest way avoiding RegRead and error handling tricks. Optional friendly consts for the registry:
Const HKEY_CLASSES_ROOT  = &H80000000
Const HKEY_CURRENT_USER  = &H80000001
Const HKEY_LOCAL_MACHINE  = &H80000002
Const HKEY_USERS  = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Then check with:
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
If oReg.EnumKey(HKEY_LOCAL_MACHINE, "SYSTEM\Example\Key\", "") = 0 Then
MsgBox "Key Exists"
Else
MsgBox "Key Not Found"
End If
IMPORTANT NOTES FOR THE ABOVE:
Equals zero means the key EXISTS.
The slash after key name is optional and not required.
In case anyone else runs into this, I took WhoIsRich's example and modified it a bit. When calling ReadReg I needed to do the following: ReadReg("App", "HKEY_CURRENT_USER\App\Version") which would then be able to read the version number from the registry, if it existed. I also am using HKCU since it does not require admin privileges to write to.
Function ReadReg(RegKey, RegPath)
Const HKEY_CURRENT_USER = &H80000001
Dim objRegistry, oReg
Set objRegistry = CreateObject("Wscript.shell")
Set oReg = GetObject("winmgmts:!root\default:StdRegProv")
if oReg.EnumKey(HKEY_CURRENT_USER, RegKey) = 0 Then
ReadReg = objRegistry.RegRead(RegPath)
else
ReadReg = ""
end if
End Function
edit (sorry I thought you wanted VBA).
Anytime you try to read a non-existent value from the registry, you get back a Null. Thus all you have to do is check for a Null value.
Use IsNull not IsEmpty.
Const HKEY_LOCAL_MACHINE = &H80000002
strComputer = "."
Set objRegistry = GetObject("winmgmts:\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
strValueName = "Test Value"
objRegistry.GetStringValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue
If IsNull(strValue) Then
Wscript.Echo "The registry key does not exist."
Else
Wscript.Echo "The registry key exists."
End If
See the Scripting Guy! Blog:
How Can I Tell Whether a Value Exists in the Registry?
They discuss doing the check on a remote computer and show that if you read a string value from the key, and if the value is Null (as opposed to Empty), the key does not exist.
With respect to using the RegRead method, if the term "key" refers to the path (or folder) where registry values are kept, and if the leaf items in that key are called "values", using WshShell.RegRead(strKey) to detect key existence (as opposed to value existance) consider the following (as observed on Windows XP):
If strKey name is not the name of an existing registry path, Err.Description reads "Invalid root in registry key"... with an Err.Number of 0x80070002.
If strKey names a registry path that exists but does not include a trailing "\" the RegRead method appears to interpret strKey as a path\value reference rather than as a simple path reference, and returns the same Err.Number but with an Err.Description of "Unable to open registry key". The term "key" in the error message appears to mean "value". This is the same result obtained when strKey references a path\value where the path exists, but the value does not exist.
The accepted answer is too long, other answers didn't work for me. I'm gonna leave this for future purpose.
Dim sKey, bFound
skey = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\SecurityHealth"
with CreateObject("WScript.Shell")
on error resume next ' turn off error trapping
sValue = .regread(sKey) ' read attempt
bFound = (err.number = 0) ' test for success
on error goto 0 ' restore error trapping
end with
If bFound Then
MsgBox = "Registry Key Exist."
Else
MsgBox = "Nope, it doesn't exist."
End If
Here's the list of the Registry Tree, choose your own base on your current task.
HKCR = HKEY_CLASSES_ROOT
HKCU = HKEY_CURRENT_USER
HKLM = HKEY_LOCAL_MACHINE
HKUS = HKEY_USERS
HKCC = HKEY_CURRENT_CONFIG

Search for registry key in all of the subkeys of a path

I want to find the key "Device Parameters' under HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\IDE.
But, the BD/DVD/CD ROM/Writers makes a different key in every system. Mine currently is HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\IDE\CdRomHL-DT-ST_DVDRAM_GH20NS15________________IL00____\5&15602d3e&0&0.1.0\Device Parameters.
But I want to search every subkey under IDE and under BD/DVD/CD ROM/Writers to get the device parameters. There is a binary value DefaultDVDregion and i want to set it to 0 for every BD/DVD/CD ROM/Writers.
I'd like to do this in VBScript.
This code will loop through all the keys in HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\IDE and, for each key, look inside it to print out the DWORD value of DefaultDvdRegion.
Option Explicit
Const HKEY_LOCAL_MACHINE = &H80000002
Dim oReg : Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Dim oShell : Set oShell = CreateObject("WScript.Shell")
Dim sPath, aSub, sKey, aSubToo, sKeyToo, dwValue
' Get all keys within sPath
sPath = "SYSTEM\CurrentControlSet\Enum\IDE"
oReg.EnumKey HKEY_LOCAL_MACHINE, sPath, aSub
' Loop through each key
For Each sKey In aSub
' Get all subkeys within the key 'sKey'
oReg.EnumKey HKEY_LOCAL_MACHINE, sPath & "\" & sKey, aSubToo
For Each sKeyToo In aSubToo
' Try and get the DWORD value in Device Parameters\DefaultDvdRegion
oReg.GetDWORDValue HKEY_LOCAL_MACHINE, sPath & "\" & sKey & "\" & sKeyToo & "\Device Parameters", "DefaultDvdRegion", dwValue
Wscript.Echo "DVDRegion of " & sPath & "\" & sKey & "\" & sKeyToo & " = " & dwValue
Next
Next
It's not my finest code, but should give you what you are looking for. On my machine, I get the following output:
DVDRegion of SYSTEM\CurrentControlSet\Enum\IDE\CdRomOptiarc_DVD_RW_AD-7200S_________________1.0A____\5&3308a5ad&0&1.0.0 = 2
DVDRegion of SYSTEM\CurrentControlSet\Enum\IDE\DiskSAMSUNG_HD103UJ_________________________1AA01113\5&76d4b99&0&0.0.0 =
Which makes sense, because my DVD drive has a region code of 2 (Europe) and my hard drive has no region code.

Resources