Retrieve Windows Product Key

RE: Retrieve Windows Product Key (chrisupman)

Mon, 22 Mar 2010 04:52:56 GMT

Has anyone had any success in getting this script to work in a windows x64 environment?

I have been trying to get the HTA version to work in windows 7 x64 by spawning the old script host
Set oSH = CreateObject("WScript.Shell")
Set oFS = CreateObject("Scripting.FileSystemObject")

strOldWSH = oSH.ExpandEnvironmentStrings("%SYSTEMROOT%\SysWOW64\wscript.exe")
If oFS.FileExists(strOldWSH) Then
    If Not UCase(WScript.FullName) = UCase(strOldWSH) Then
        oSH.Run """" & strOldWSH & """ """ & WScript.ScriptFullName & """", 1, False
        WScript.Echo "Running on 64-bit WSH."



    End If
End If
This information was posted on the MS scripting guys site.

I have had no luck in getting any results.

What tecnniques

RE: Retrieve Windows Product Key (dm_4ever)

Wed, 18 Feb 2009 21:13:59 GMT

Simply assign computers to the array ActiveCompList and use the existing code.

RE: Retrieve Windows Product Key (travisb)

Fri, 13 Feb 2009 09:01:39 GMT

Is it possible to add a list of computer names or IP addresses that you want scanned? This way you do not have to scan the entire domain. I'm new to VBS and not sure where I would start. Can anyone help with this?

RE: Retrieve Windows Product Key (fletchjake)

Fri, 07 Nov 2008 14:16:35 GMT

Hi,
This is a great script, I am ENTIRELY new to VB so I am lost...I got it running pulled my windows product id from the domain and all is good that way.

I have a couple questions though:

1. I can't get it to work so I can pull the office, visio, or other MS product id's? Anyone able to help? I am using the script below:
2. I also want to see if this can go to a csv file or excel?

' ##########################################
' #            #
' # VBScript to Retrieve a List of Computers from Active #
' # Directory, check connectivity and generate a report file #
' # containing Microsoft Windows Licensing Information. #
' #            #
' ##########################################
'
Dim objDomain, strComputer, strADComputer, PC, strKeyPath, strValueName, oReg
Dim ADCompList, ActiveCompList, RetrievedKeys
Dim IE, oFSO, objShell, strPath, objFile
Set IE = CreateObject("InternetExplorer.Application")
Set objShell = CreateObject("Wscript.Shell")
strPath = Wscript.ScriptFullName
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(strPath)
strPath = objFSO.GetParentFolderName(objFile)
With IE
.left=200
.top=200
.height=140
.width=250
.menubar=0
.toolbar=0
.statusBar=0
.navigate "About:Blank"
.visible=1
End With
'wait a while until IE as finished to load
Do while IE.busy
loop
With IE.document
.Open
.WriteLn "<html>"
.WriteLn "<head>"
.WriteLn "<HTA:APPLICATION "
.WriteLn "     ID='objNoTitleBar'"
.WriteLn "     CAPTION=no"
.WriteLn "     SHOWINTASKBAR='NO'"
.WriteLn "     BORDER='NONE'"
.WriteLn "     APPLICATIONNAME='Please Wait'"
.WriteLn "     SCROLL='AUTO'"
.WriteLn "     SINGLEINSTANCE='yes'"
.WriteLn ">"
.WriteLn "</head>"
.WriteLn "<body text='#ffffff' bgcolor='#000000'>"
.WriteLn "<center>Please Wait....<br /><br />"
.WriteLn "<img src='" & strPath & "\ajax-loader.gif' /></center>"
.WriteLn "</body>"
.WriteLn "</html>"
.Close
End With
ADCompList = Array(0)
' Connect to root of domain
Dim rootDSE, domainContainer
Set rootDSE = GetObject("LDAP://RootDSE")
domainContainer = rootDSE.Get("defaultNamingContext")
Set ObjDomain = GetObject("LDAP://" & domainContainer)
' Enumerate through the domain
WorkWithObject(ObjDomain)
Sub WorkWithObject(oContainer)
Dim oADObject
For Each oADObject in oContainer
Select Case oADObject.Class
Case "computer"
Dim strADComputer
strADComputer = oADObject.cn
ADCompList(UBound(ADCompList)) = strADComputer
ReDim Preserve ADCompList(UBound(ADCompList) + 1)
Case "organizationalUnit" , "container"
WorkWithObject(oADObject)
End Select
Next
End Sub
ReDim Preserve ADCompList(UBound(ADCompList) - 1)
ActiveCompList = Array(0)
For Each PC In ADCompList
If Reachable(PC) Then
ActiveCompList(UBound(ActiveCompList)) = PC
ReDim Preserve ActiveCompList(UBound(ActiveCompList) + 1)
End If
Next
ReDim Preserve ActiveCompList(UBound(ActiveCompList) - 1)
Set objXMLDoc = CreateObject("Microsoft.XMLDOM")
Set rootEl = objXMLDoc.createElement("Computers")
objXMLDoc.appendChild rootEl
Dim objCurrNode, objNewNode, objNewText
' <--------------- Open Registry Key and populate binary data into an array -------------------------->
const HKEY_LOCAL_MACHINE = &H80000002
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
strValueName = "DigitalProductId"
Dim iValues()
On Error Resume Next
For Each strComputer In ActiveCompList
Set objPCField = objXMLDoc.createElement("PC")
rootEl.appendChild(objPCField)
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
oReg.GetBinaryValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,iValues
Dim arrDPID
arrDPID = Array()
For i = 52 to 66
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
' <--------------- Create an array to hold the valid characters for a microsoft Product Key -------------------------->
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")
' <--------------- The clever bit !!! (Decrypt the base24 encoded binary data)-------------------------->
strProductKey = ""
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
strFinalKey = strProductKey
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery("select * from Win32_OperatingSystem")
For Each objOperatingsystem in colOperatingSystems
strOS   = objOperatingsystem.Caption
strBuild   = objOperatingsystem.BuildNumber
strSerial   = objOperatingsystem.SerialNumber
strRegistered = objOperatingsystem.RegisteredUser
Next
Set objNewNode = objXMLDoc.createElement("Name")
Set objNewText = objXMLDoc.createTextNode(strComputer)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("OS")
Set objNewText = objXMLDoc.createTextNode(strOS)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("Build")
Set objNewText = objXMLDoc.createTextNode(strBuild)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("PID")
Set objNewText = objXMLDoc.createTextNode(strSerial)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("RegisteredTo")
Set objNewText = objXMLDoc.createTextNode(strRegistered)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("Key")
Set objNewText = objXMLDoc.createTextNode(strFinalKey)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Next
'Add an XML processing instruction and insert it before the root element
Set p=objXMLDoc.createProcessingInstruction("xml","version='1.0'")
xmlDoc.insertBefore p,objXMLDoc.childNodes(0)
objXMLDoc.Save("report.xml")
IE.Quit
set IE = Nothing
MsgBox("Finished")
' <----------------------- Function to check if computer is switched on and responding to Ping ---------------------->
Function Reachable(strComputer)
' On Error Resume Next
Dim wmiQuery, objWMIService, objPing, objStatus
wmiQuery = "Select * From Win32_PingStatus Where Address = '" & strComputer & "'"
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objPing = objWMIService.ExecQuery(wmiQuery)
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) Or objStatus.Statuscode<>0 Then
Reachable = False 'if computer is unreacable, return false
Else
Reachable = True 'if computer is reachable, return true
End If
Next
End Function

RE: Retrieve Windows Product Key (mbouchard)

Thu, 04 Sep 2008 04:12:46 GMT

The error you are getting means that you have arrDPID dimmed twice. If you are only using it in the function, remove the dim at the top of the script. If you are using it in both places, remove the dim from the function.

RE: Retrieve Windows Product Key (hickory420)

Wed, 03 Sep 2008 20:12:41 GMT

Thanks for that, mbouchard. When I moved it out of the if else then statements, I stopped getting the syntax error as well! But I do get a different error :-P , Name Redifined.

The line is it complaining about is "Dim iValues, arrDPID". I put the Function right above the first For statement "For i = intStartingAddressInput to intEndingAddressInput"

I was actually happy that I got a different error message. sad isn't it....
Don't get me wrong, I will be Cheering once the script is working and I will post the final product to share with everyone because you guys rock!

again.

RE: Retrieve Windows Product Key (p0ng)

Wed, 03 Sep 2008 12:05:35 GMT

Very nice Parabellum

Now your next task should be to create an HTA to change the registered keys.

RE: Retrieve Windows Product Key (mbouchard)

Wed, 03 Sep 2008 07:08:50 GMT

Try moving the function outside of the If else then. As soon as I did that I stopped getting a syntax error message in PrimalScript

RE: Retrieve Windows Product Key (hickory420)

Tue, 02 Sep 2008 19:58:24 GMT

Hi Guys!

Parabellum, I have to say, Very well done with your script. It's exactly what i've been looking for! Legend!

But I have a slight hiccup... I have integrated your script with one from microsofts TechNet website and now I am getting a Syntax Error on Line 102 Character 1

That line is: Function decodeKey(iValues, strProduct)

I am pretty good at vbs, but this one threw me in for quite a loop..... I don't know how to fix it.

It honestly makes no sence at all because essentially all I am doing is pinging each computer and if it replys it runs the keycheck script against that machine then dumps it to a file,
then moves on to the next one. Why Syntax Error? It a Function!

Can you make heads or tails of this?

Thanks to Any/Everyone in advance!

 On Error Resume Next
 
 Const WbemAuthenticationLevelPktPrivacy = 6
 
 strCredentials = InputBox _
    ("Please enter the user name, a blank space, and then the password:", _
    "Enter User Credentials")
 
 If strCredentials = "" Then
    Wscript.Echo "Username and password must be provided. Now quitting."
    Wscript.Quit
    End If
 
    arrCredentials = Split(strCredentials," ")
    strUser = arrCredentials(0)
    strPassword = arrCredentials(1)
 
 strSubnetInput = InputBox("Enter the SubNet of the network you wish to scan." & VbCrLf &_
 VbCrLf & " Example: 192.168.xx.1")
 
 intStartingAddressInput = InputBox("Enter the starting address of the ping scan." & VbCrLf &_
 VbCrLf & "Example: 192.168." & strSubnetInput & ".1-254")
 
 intEndingAddressInput = InputBox("Enter the ending address of the Ping scan" & VbCrLf &_
 VbCrLf & "Example: 192.168." & strSubnetInput & "." & intStartingAddressInput & "-255")
 
 strSubnet = "192.168."& strSubnetInput &"."
 
 For i = intStartingAddressInput to intEndingAddressInput
    strComputer = strSubnet & i
 
    Set objShell = CreateObject("WScript.Shell")
    strCommand = "%comspec% /c ping -n 1 -w 200 " & strComputer & ""
    Set objExecObject = objShell.Exec(strCommand)
 
    Do While Not objExecObject.StdOut.AtEndOfStream
        strText = objExecObject.StdOut.ReadAll()
        If Instr(strText, "Reply") > 0 Then
 Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
    Set objWMIService = objwbemLocator.ConnectServer _
    (strComputer, strNamespace, strUser, strPassword)
    objWMIService.Security_.authenticationLevel = WbemAuthenticationLevelPktPrivacy
 
    Set objFileSys = CreateObject ("Scripting.FileSystemObject")  
 logfile = "PingPong." & strSubnetInput & ".txt"
 Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
    filetemp.Write strComputer & " Ping... Pong"
    filetemp.Write VbCrLf
    filetemp.Close
 '===============================================================
 '  ##############################################################
 '  #        #
 '  # VBScript to retrieve Microsoft Product Keys  #
 '  # from the registry by decoding DigitalProductID's #
 '  #        #
 '  # -------------------------------------------------- #
 '  # Created by: Parabellum     #
 '  #        #
 '  ##############################################################
 '
 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"
 
 ' <--------------- Open Registry Key and populate binary data into an array -------------------------->
 
 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("Finished")
 
 ' <----------------------------------------- Return the Product Key --------------------------------------------------->
 Function decodeKey(iValues, strProduct)
 
 Dim arrDPID
 arrDPID = Array()
 
 ' <--------------- extract bytes 52-66 of the DPID -------------------------->
 For i = 52 to 66
 ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
 arrDPID( UBound(arrDPID) ) = iValues(i)
 Next
 
 ' <--------------- Create an array to hold the valid characters for a microsoft Product Key -------------------------->
 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")
 
 ' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
 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)
 
 Set objFileSys = CreateObject ("Scripting.FileSystemObject")  
 logfile = "PC-Info.txt"
 Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
    filetemp.Write strComputer
    filetemp.Write strProduct & vbNewLine & foundKeys(strKey) & vbNewLine 
    filetemp.Write VbCrLf
    filetemp.Close
 
 End Function
 ' =====================================================================
 Else
 Set objFileSys = CreateObject ("Scripting.FileSystemObject")  
 logfile = "PingPong." & strSubnetInput & ".txt"
 Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
    filetemp.Write strComputer & " Ping..."
    filetemp.Write VbCrLf
    filetemp.Close
 End If
 Loop
 Next

RE: Retrieve Windows Product Key (Parabellum)

Fri, 18 Jan 2008 08:48:15 GMT

sorry, i haven't checked this for a while.
Sorry to say... the reason I didn't add support for office 2000 is because you can't retrieve the key from the registry for office 2000
It is only in versions XP or later that micrsoft started storing the key in this way.
I haven't yet found any tool... vbs or other that can retrieve a 2000 key.
If you know of one, let me know and i will try and find out how it works and see if I can modify the script to add this feature.
hope this answere your question.

P

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 14:56:33 GMT

I tried tweaking the script to look under ProductID, with no luck.

After some extensive research, reading Help files for stand-alone key finder apps and whatnot, everywhere I'm looking is saying that Office 2000 does not store the key and the key cannot be retrieved. This is beautiful, since the majority of the machines at our office have office 2000...

So, if anyone can find anything to the contrary, please advise. I would REALLY love to be able to automate the key retrieval for asset management. But, if not, I guess that's life!

Thanks, all

RE: Retrieve Windows Product Key (ebgreen)

Mon, 07 Jan 2008 14:31:07 GMT

So it looks like maybe the info is in ProductID for 2k?

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 14:02:37 GMT

Ok. This doesn't look good. I'm going to double check this on a different machine.

The location is still the same, but there does not seem to be a value in the DigitalProductID key. Here's a dump from the entire "Registration" tree:

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\9.0\Registration]
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\9.0\Registration\DigitalProductID]
@=""
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\9.0\Registration\ProductID]
@="08706-OEM-0086151-38750"

RE: Retrieve Windows Product Key (ebgreen)

Mon, 07 Jan 2008 13:26:53 GMT

Looks like it looks at every subkey under to product root key (i.e. every subkey under SOFTWARE\Microsoft\Office\10.0\Registration for Office XP). In each subkey it looks for a value named DigitalProductID. You will need to find out how Office 2k differs from this.

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 13:18:10 GMT

The script looks to me like it always assumes that there is a GUID folder. But I could be misreading it... Either way, I'm not experienced enough with VBS to even determine that for sure, much less re-write the code. There is a lot of syntax mixed in that is unfamiliar to me. The GUID logic is in the "ELSE" portion of an IF statement, so for all I know, the initial IF is determining if there is no GUID folder. If that is the case, then the logic is already there and is just not working. Otherwise, I'm totally off the mark.

Anyway, I'm hoping someone on here can offer some more specific suggestions of code changes to try.

RE: Retrieve Windows Product Key (ebgreen)

Mon, 07 Jan 2008 13:03:33 GMT

Sounds like you have some modifications ahead of you.

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 13:00:07 GMT

In fact, we have some users that have even older versions of office installed, and they don't have the GUID folder either.

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 12:56:17 GMT

I'm waiting on a regedit screenshot off an XP machine running office 2000. In the mean time, I can tell you that the "DigitalProductID" is directly under "Registration", and not under a GUID subfolder. I'm thinking that is the culprit...

RE: Retrieve Windows Product Key (ebgreen)

Mon, 07 Jan 2008 12:33:07 GMT

I don't have a machine with Office 2000 on it to check, but are you sure that the registration information Office 2k is at that registry path?

RE: Retrieve Windows Product Key (NewLeafIT)

Mon, 07 Jan 2008 12:27:52 GMT

I am a noob to VBS and the related languages (my experience is more in Shell/Bash/PHP/Perl) so please bear with my ignorance...

I have been trying some of the scripts in this post, and they appear to work well for many of my machines. I'm using the HTA version now but the older machines running Office 2000 are not working. It's failing to retrieve the information for MS Office, and returns only the OS info. I modified the script to include 2000, but I must have done something wrong.

I edited Line 23 and added a new element to the array (lines 36 & 37). Here's my code. Could someone please tell me what I am missing?

Thanks...

 <html>
 <head>
 <title>Microsoft Product Key Retrieval</title>
 <hta:application
 applicationname="MSKeyRetrieval" 
 caption="MSKeyRetrieval"
 contextmenu="no"
 maximizebutton="no"
 minimizebutton="yes"
 navigable="yes"
 showintaskbar="yes"
 singleinstance="yes"
 sysmenu="yes"
 >
 </head>
 <script language="VBScript">
 Const HKEY_LOCAL_MACHINE = &H80000002
 Const SEARCH_KEY = "DigitalProductID"
 Dim foundKeys
 Dim iValues
 Dim arrDPID
 Dim strHTML
 Dim arrSubKeys(5,1)
 foundKeys = Array()
 iValues = Array()
 arrSubKeys(0,0) = "Microsoft Windows"
 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"
 arrSubKeys(5,0) = "Microsoft Office 2000"
 arrSubKeys(5,1) = "SOFTWARE\Microsoft\Office\9.0\Registration"
 Sub window_onload
 ' <--------------- Set window Size --------------->
        strComputer = "."
        Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
        Set colItems = objWMIService.ExecQuery("Select * From Win32_DesktopMonitor")
        For Each objItem in colItems
            intHorizontal = objItem.ScreenWidth
            intVertical = objItem.ScreenHeight
        Next
        intLeft = (intHorizontal - 500) / 2
        intTop = (intVertical - 600) / 2
        window.resizeTo 500,600
        window.moveTo intLeft, intTop
  
 ' <--------------- Open Registry Key and populate binary data into an array -------------------------->
 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
 If IsNull(foundkeys) Then
  DataArea.InnerHTML = "No Keys Found" 
 Else
  DataArea.InnerHTML = strHTML
 End If 
 End Sub
 ' <----------------------- Return the Product Key ------------------------>
 Function decodeKey(iValues, strProduct)
 Dim arrDPID
 arrDPID = Array()
 ' <--------------- extract bytes 52-66 of the DPID -------------------------->
 For i = 52 to 66
  ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
  arrDPID( UBound(arrDPID) ) = iValues(i)
 Next
 ' <--------------- Create an array to hold the valid characters for a microsoft Product Key -------------------------->
 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")
 ' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
 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
 If strProduct = "Microsoft Windows" Then
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
  Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
  For Each objOperatingSystem in colOperatingSystems
   strOS = objOperatingSystem.Caption
  Next
  strHTML = strHTML & "<h3>" & strOS & "</h3>" & _
    "<h4>" & strProductKey & "</h4><br /><hr /><br />"
 Else
  strHTML = strHTML & "<h3>" & strProduct & "</h3>" & _
    "<h4>" & strProductKey & "</h4><br /><hr /><br />"
 End If
 End Function
 </script>
 <body>
 <div id="header" style="color:#ffffff; height:100px; text-align:center; font-family:Tahoma;
  filter:progid:DXImageTransform.Microsoft.Gradient(GradientType=0, StartColorStr='#0011aa', EndColorStr='#ffffff')">
  <br /><h2>Retrieved Microsoft Product Keys</h2>
 </div><hr />
 <span id="DataArea"></span>
 <br />
 <div id="Print" style="text-align:center;"><input type="button" value="Print" Onclick="print()" ;></div>
 </body>
 </html>