See Windows Serial VBS

CONST HKEY_LOCAL_MACHINE = &H80000002

CONST SEARCH_KEY = "DigitalProductID"

Dim arrSubKeys(4,1)

Dim foundKeys

Dim iValues, arrDPID

foundKeys = Array()

iValues = Array()

arrSubKeys(0,0) = "Microsoft Windows Product Key"

arrSubKeys(0,1) = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"

arrSubKeys(2,0) = "Microsoft Office XP"

arrSubKeys(2,1) = "SOFTWARE\Microsoft\Office\10.0\Registration"

arrSubKeys(1,0) = "Microsoft Office 2003"

arrSubKeys(1,1) = "SOFTWARE\Microsoft\Office\11.0\Registration"

arrSubKeys(3,0) = "Microsoft Office 2007"

arrSubKeys(3,1) = "SOFTWARE\Microsoft\Office\12.0\Registration"

arrSubKeys(4,0) = "Microsoft Exchange Product Key"

arrSubKeys(4,1) = "SOFTWARE\Microsoft\Exchange\Setup"

strComputer = "."

Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

For x = LBound(arrSubKeys, 1) To UBound(arrSubKeys, 1)

oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1), SEARCH_KEY, arrDPIDBytes

If Not IsNull(arrDPIDBytes) Then

call decodeKey(arrDPIDBytes, arrSubKeys(x,0))

Else

oReg.EnumKey HKEY_LOCAL_MACHINE, arrSubKeys(x,1), arrGUIDKeys

If Not IsNull(arrGUIDKeys) Then

For Each GUIDKey In arrGUIDKeys

oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1) & "\" & GUIDKey, SEARCH_KEY, arrDPIDBytes

If Not IsNull(arrDPIDBytes) Then

call decodeKey(arrDPIDBytes, arrSubKeys(x,0))

End If

Next

End If

End If

Next

MsgBox("Selesai")

Function decodeKey(iValues, strProduct)

Dim arrDPID

arrDPID = Array()

For i = 52 to 66

ReDim Preserve arrDPID( UBound(arrDPID) + 1 )

arrDPID( UBound(arrDPID) ) = iValues(i)

Next

Dim arrChars

arrChars = Array("B","C","D","F","G","H","J","K","M","P","Q","R","T","V","W","X","Y","2","3","4","6","7","8","9")

For i = 24 To 0 Step -1

k = 0

For j = 14 To 0 Step -1

k = k * 256 Xor arrDPID(j)

arrDPID(j) = Int(k / 24)

k = k Mod 24

Next

strProductKey = arrChars(k) & strProductKey

If i Mod 5 = 0 And i <> 0 Then strProductKey = "-" & strProductKey

Next

ReDim Preserve foundKeys( UBound(foundKeys) + 1 )

foundKeys( UBound(foundKeys) ) = strProductKey

strKey = UBound(foundKeys)

MsgBox strProduct & vbNewLine & vbNewLine & foundKeys(strKey)

End Function

See Windows Serial VBS

Unknown maandag 1 februari 2016