Option Explicit
Dim objFSO,objTxt,objShell
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objTxt = objFSO.OpenTextFile("Reg_Show_Values1.txt", ForWriting, true, -2)
Set objShell = WScript.CreateObject("WScript.Shell")

Dim strComputer 'ホスト名（ローカル コンピュータ）
strComputer = "."
'ハイブを定数に設定
Const HKCR = &H80000000
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
'元のハイブ名
Redim strHiveFullName(3)
strHiveFullName(0) = "HKEY_CLASSES_ROOT\"
strHiveFullName(1) = "HKEY_CURRENT_USER\"
strHiveFullName(2) = "HKEY_LOCAL_MACHINE\"
strHiveFullName(3) = "HKEY_USERS\"

Dim strFullPath, strHive, strKeyPath
'フルパスを入力
strFullPath = myInput
'ハイブを設定
strHive = myHive(strFullPath)
'キーを設定
strKeyPath = myKey(strFullPath)
'Sub ShowRegValues
ShowRegValues strHive

objTxt.Close
objShell.Run "Reg_Show_Values1.txt"
Set objTxt = Nothing
Set objFSO = Nothing
Set objShell = Nothing

'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\LSA
'HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders
'HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run
'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\AGP

'*********************************************************
'Function myInput
'*********************************************************
Function myInput()
	myInput = InputBox("パスを入力してください", "レジストリの値エントリを書き出し")
	If IsEmpty(myInput) Then WScript.Quit
	If myInput = "" Then
		myInput
	End If
End Function

'*********************************************************
'Function myHive
'*********************************************************
Function myHive(strFullPath)
	Dim intX, strHives
	For intX = 0 To 3
		strHives = Array(HKCR, HKCU, HKLM, HKU)
		If InStr(strFullPath, strHiveFullName(intX)) = 1 Then
			myHive = strHives(intX)
		End If
	Next
End Function

'*********************************************************
'Function myKey
'*********************************************************
Function myKey(strFullPath)
	Dim intY
	For Each intY In strHiveFullName
		If InStr(strFullPath, intY) = 1 Then
			myKey = Replace(strFullPath, intY, "")
		End If
	Next
End Function

'*********************************************************
'Sub ShowRegValues
'*********************************************************
Sub ShowRegValues(strHive)
	Dim objReg ' オブジェクト Regestryプロバイダ
	Set objReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
	objTxt.WriteLine "============================================================"
	objTxt.WriteLine strFullPath
	objTxt.WriteLine "============================================================"
	Dim arrValueNames 'レジストリ値の名前の配列を保持
	Dim arrValueTypes 'レジストリ値のデータの種類の配列を保持
	objReg.EnumValues strHive, strKeyPath, arrValueNames, arrValueTypes

	Dim i, j ,k
	For i = 0 To UBound(arrValueNames)
		Dim myValue
		objTxt.WriteLine "Value Name : " & arrValueNames(i)
		Select Case arrValueTypes(i)
			Case REG_SZ
				objTxt.WriteLine "Data Type  : String (REG_SZ)"
				objReg.GetStringValue strHive,strKeyPath,arrValueNames(i), myValue
				objTxt.WriteLine "データ     : " & myValue
			Case REG_EXPAND_SZ
				objTxt.WriteLine "Data Type  : Expanded String (REG_EXPAND_SZ)"
				objReg.GetExpandedStringValue strHive,strKeyPath,arrValueNames(i), myValue
				objTxt.WriteLine "データ     : " & myValue
				objTxt.WriteLine "データ (RegRead) : " & objShell.RegRead(strFullPath & "\" & arrValueNames(i))
			Case REG_BINARY
				objTxt.WriteLine "Data Type  : Binary (REG_BINARY)"
				objReg.GetBinaryValue strHive,strKeyPath,arrValueNames(i), myValue
				objTxt.Write "データ(Hex): "
				For k = 0 To UBound(myValue)
					objTxt.Write Hex(myValue(k)) & ","
				Next
				objTxt.WriteBlankLines(1)
			Case REG_DWORD
				objTxt.WriteLine "Data Type  : WORD (REG_DWORD)"
				objReg.GetDWORDValue strHive,strKeyPath,arrValueNames(i), myValue
				objTxt.WriteLine "データ     : " & myValue
				objTxt.WriteLine "データ     : " & Hex(myValue) & "(Hex)"
			Case REG_MULTI_SZ
				objTxt.WriteLine "Data Type  : Multi String (REG_MULTI_SZ)"
				objReg.GetMultiStringValue strHive,strKeyPath,arrValueNames(i), myValue
				For j=0 To UBound(myValue)
					objTxt.WriteLine "データ     : " & myValue(j)
				Next
		End Select
		objTxt.WriteBlankLines(1)
	Next
End Sub