'  ############################################################################################################## 
'  # VBScript to retrieve Microsoft Product Keys from the registry by decoding DigitalProductIDs
'  # -------------------------------------------------- 
'  # Created by: Parabellum    
'  # Modified by: Steven Manross  
'  #        2010/10/23 -- Took out static references to names of products and instead 
'  #                      take them from the registry as designed (dynamically pulling
'  #                      names like: Office, Project, Visio, Office Professional, Office Home and Student, etc)
'  #                   -- added x64 and x86 (in x64) product key gathering
'  #        2010/12/11 -- Simplified code, created find_digital_product_key_from_registry function, removed
'  #                      registry enumeration if we are looking at the Windows NT\CurrentVersion subkey  
'  #   
'  # First posted on http://www.visualbasicscript.com/m42793.aspx
'  #    
'  ############################################################################################################## 
' 
On Error Resume Next

CONST HKLM = &H80000002 

if WScript.Arguments.Count > 0 Then
  for each arg in WScript.Arguments
    rtn = get_product_keys(arg)
  Next
Else
  rtn = get_product_keys(".")
End If
Function get_product_keys (strComputer)
  On Error Resume Next

  foundKeys = Array()
  '  Enum the keys you what to poll
  ' apparently Microsoft is a little superstitious...  No Office version = 13.0  :)

  KeySoftware = Array("SOFTWARE", _
                       "SOFTWARE\Wow6432Node" _
                      ) 
  KeyNames = Array("Microsoft\Windows NT\CurrentVersion", _
                    "Microsoft\Office\10.0\Registration", _
                    "Microsoft\Office\11.0\Registration", _
                    "Microsoft\Office\12.0\Registration", _
                    "Microsoft\Office\14.0\Registration" _
                   )

  Set oReg = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv") 
  if strComputer = "." Then
    oReg.GetStringValue HKLM, "System\CurrentControlSet\Control\ComputerName\ActiveComputerName", "ComputerName",compname
  Else
    compname = strComputer
  End If
  
  WScript.Echo compname
  For each prefix in KeySoftware  ''allow for 32bit keys in 64-bit OSes (the native 64-bit keys will be in "Software")
    For each keyname in KeyNames 
      rtn = find_digital_product_key_from_registry(oReg,prefix & "\" & keyname,prodname,prodkey)
      if rtn = 1 Then
        WScript.Echo "  " & prodname & " - " & prodkey
      Else 
        If keyname <> "Microsoft\Windows NT\CurrentVersion" Then ''dont enumerate the registry keys here
          oReg.EnumKey HKLM, prefix & "\" & keyname, arrGUIDKeys 
          If Not IsNull(arrGUIDKeys) Then 
            For Each GUIDKey In arrGUIDKeys 
              rtn = find_digital_product_key_from_registry (oReg,prefix & "\" & keyname & "\" & GUIDKey,prodname,prodkey)
              if rtn = 1 Then
                WScript.Echo "  " & prodname & " - " & prodkey
              End If 
            Next 
          End If
        End If
      End If 
    Next 
  Next 
  get_product_keys = 1
End Function

Function decodeDigitalProductKey(DigitalProductID,strProductKey) 
  On Error Resume Next
  'decode the product key from the registry and output it
  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) ) = DigitalProductID(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
   End If
  Next
End Function 

Function find_digital_product_key_from_registry (oReg,regkeyname,productname,productkey)
  On Error Resume Next
  oReg.GetBinaryValue HKLM, regkeyname, "DigitalProductID", arrDPIDBytes 
  if Err.Number <> 0 Then
    Err.Clear
    '' it may not exist
  End If
  If Not IsNull(arrDPIDBytes) Then 
    oReg.GetStringValue HKLM, regkeyname, "ProductName" ,productname
    if Err.Number <> 0 Then
      WScript.Echo "Error retrieving Product Name: " & Hex(Err.Number) & " - " & Err.Description
      Err.Clear
    End If
    rtn = decodeDigitalProductKey(arrDPIDBytes,productkey) 
    If Err.Number <> 0 Then
      WScript.Echo "Error exiting from decodeDigitalProductKey: " & Hex(Err.Number) & " - " & Err.Description
      Err.Clear
      find_digital_product_key_from_registry = 0
      Exit Function
    End If
  Else
    find_digital_product_key_from_registry = 0
    Exit Function
  End If
  find_digital_product_key_from_registry = 1
End Function