'  ##############################################################
 '  #        #
 '  # 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 -------------------------->
 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("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)
  MsgBox strProduct & vbNewLine & vbNewLine & foundKeys(strKey)
 End Function