Option Explicit
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const REG_QWORD = 11
Const FILE_APPEND_MODE = 8
Dim WshShell, reg, fso, ts
Dim sLog, Profile, sPrefix, strKey, sComment, hive, hasKeyHeader, hasComment
Set WshShell = CreateObject("WScript.Shell")
Set reg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Set fso = CreateObject("Scripting.FileSystemObject")
hive = 0
sLog = WScript.Arguments(0)
Profile = WScript.Arguments(1)
sPrefix = WSCript.Arguments(2)
strKey = WSCript.Arguments(3)
sComment = WSCript.Arguments(4)
Set ts = fso.OpenTextFile(sLog, FILE_APPEND_MODE, true)
NormalizeKeyNameAndHiveHandle hive, sPrefix
EnumerateKeys hive, sPrefix, strKey
ts.Close
Sub EnumerateKeys(hive, sPrefix, key)
On Error Resume Next
Dim i, name, iType, arrNames, arrTypes, PrefAndKey, arrSubKeys, subkey
PrefAndKey = BuildPath(sPrefix, key)
reg.EnumValues hive, PrefAndKey, arrNames, arrTypes
If Not IsNull(arrNames) Then
for i = 0 to Ubound(arrNames)
name = arrNames(i)
iType = arrTypes(i)
if name <> "" and IsNumeric(iType) then
if not hasComment Then
LogKey vbCrLf & ";" & sComment
hasComment = true
end if
if not hasKeyHeader Then
LogKey key
hasKeyHeader = true
end if
LogValue name & ";" & GetKeyTypeName(iType) & ";" & ReadParam(hive, PrefAndKey, name, iType)
end if
next
end if
reg.EnumKey hive, PrefAndKey, arrSubKeys
If Not IsNull(arrSubKeys) Then
hasKeyHeader = false
For Each subkey In arrSubKeys
EnumerateKeys hive, sPrefix, key & "\" & subkey
Next
End If
End Sub
Function ReadParam(hive, key, name, iType)
Dim value, i, bData
Select Case iType
case REG_SZ: reg.GetStringValue hive, key, name, value
case REG_EXPAND_SZ: value = WshShell.RegRead(GetHiveNameByHandle(hive) & "\" & key & "\" & name)
case REG_DWORD: reg.GetDWORDValue hive, key, name, value
case REG_QWORD: reg.GetQWORDValue hive, key, name, value
case REG_MULTI_SZ:
reg.GetMultiStringValue hive, key, name, aData
If Not IsNull(aData) Then
for i = 0 to ubound(aData)
value = value & aData(i) & "\n"
next
End if
case REG_BINARY:
reg.GetBinaryValue hive, key, name, bData
If Not IsNull(bData) Then
for i = 0 to ubound(bData)
value = value & Right("0" & hex(bData(i)), 2)
next
end if
End Select
ReadParam = value
End Function
Function GetHiveNameByHandle(Handle)
Select Case Handle
Case HKEY_CLASSES_ROOT
GetHiveNameByHandle = "HKEY_CLASSES_ROOT"
Case HKEY_CURRENT_USER
GetHiveNameByHandle = "HKEY_CURRENT_USER"
Case HKEY_LOCAL_MACHINE
GetHiveNameByHandle = "HKEY_LOCAL_MACHINE"
Case HKEY_USERS
GetHiveNameByHandle = "HKEY_USERS"
Case HKEY_CURRENT_CONFIG
GetHiveNameByHandle = "HKEY_CURRENT_CONFIG"
End Select
End Function
Public Function GetHKey(ByVal HKeyName)
Dim pos
pos = InStr(HKeyName, "\")
If pos <> 0 Then HKeyName = Left(HKeyName, pos - 1)
Select Case UCase(HKeyName)
Case "HKEY_CLASSES_ROOT", "HKCR"
GetHKey = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER", "HKCU"
GetHKey = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE", "HKLM"
GetHKey = HKEY_LOCAL_MACHINE
Case "HKEY_USERS", "HKU"
GetHKey = HKEY_USERS
Case "HKEY_CURRENT_CONFIG", "HKCC"
GetHKey = HKEY_CURRENT_CONFIG
End Select
End Function
Public Function GetKeyTypeName(iType)
Select Case iType
case REG_SZ: GetKeyTypeName = "REG_SZ"
case REG_EXPAND_SZ: GetKeyTypeName = "REG_EXPAND_SZ"
case REG_DWORD: GetKeyTypeName = "REG_DWORD"
case REG_QWORD: GetKeyTypeName = "REG_QWORD"
case REG_MULTI_SZ: GetKeyTypeName = "REG_MULTI_SZ"
case REG_BINARY: GetKeyTypeName = "REG_BINARY"
End Select
End Function
Public Sub NormalizeKeyNameAndHiveHandle(ByRef lHive, ByRef in_out_KeyName)
Dim iPos
If lHive = 0 Then
lHive = GetHKey(in_out_KeyName)
iPos = InStr(in_out_KeyName, "\")
If (iPos <> 0) Then in_out_KeyName = Mid(in_out_KeyName, iPos + 1) Else in_out_KeyName = vbNullString
End If
End Sub
Sub LogKey(str)
ts.WriteLine(str)
End Sub
Sub LogValue(str)
ts.WriteLine(Profile & ";" & str)
End Sub
Function BuildPath(byval s1, byval s2)
if Right(s1, 1) = "\" then s1 = Left(s1, len(s1) - 1)
if Left(s2, 1) <> "\" then s2 = "\" & s2
BuildPath = s1 & s2
if Left(BuildPath, 1) = "\" then BuildPath = Mid(BuildPath, 2)
End Function
