VBS: Recuperare il product key di Windows tramite VBS

Esistono diversi tool di terze parti che permettono il recupero del product key del sistema operativo e di altre applicazioni, tra questi segnalo l'ottimo ProduKey della NirSoft (www.nirsoft.net) scaricabile gratuitamente ed eseguibile senza alcuna installazione.
In questo articolo verrà mostrato come recuperare il product key di Windows tramite uno script VBS.
Il Product Key di Windows è una sequenza di 25 caratteri (lettere e numeri) divisi in 5 gruppi da 5 caratteri ognuno. I caratteri utilizzati all'interno di un product key sono BCDFGHJKMPQRTVWXY2346789 mentre non vengono utilizzati i caratteri AEILNOSUZ015. Il product key è memorizzato all'interno del registro di sistema e codificato in un valore DWORD all'interno della chiave HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId.
Nella decodifica del valore DWORD DigitalProductId bisogna fare attenzione alla versione di Windows infatti, a partire da Windows 8, il metodo di codifica del product key è cambiato.

Lo script che ho creato visualizza le informazioni relative al nome del prodotto, il Product ID e il Product Key permettendo, inoltre, di salvare le informazioni trovate all'interno di un file di testo (.txt).
Di seguito il sorgente dello script VBS

Option Explicit 

Dim strComputer, objWMIService, objItem, Caption, colItems
Dim ProductName,ProductID,ProductKey,ProductInfo, Version, Win8Version, WinOlderVersion
Win8Version = "6.2 6.3"
WinOlderVersion ="6.1 6.0 5.2 5.1 5.0"

'Di seguito i valori della stringa CurrentVersion presente all'interno della chiave HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion che indica la versione di Windows
'Windows 8.1                 6.3
'Windows Server 2012 R2      6.3
'Windows 8                   6.2
'Windows Server 2012         6.2
'Windows 7                   6.1
'Windows Server 2008 R2      6.1
'Windows Server 2008         6.0
'Windows Vista               6.0
'Windows Server 2003 R2      5.2
'Windows Server 2003         5.2
'Windows XP 64-Bit Edition   5.2
'Windows XP                  5.1
'Windows 2000                5.0
'Crea oggetto wscript.shell
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)
' in Caption memorizzo la Versione di Windows
For Each objItem in colItems
    Caption = objItem.Caption  
Next
 Dim objshell,path,DigitalID, Result 
 Set objshell = CreateObject("WScript.Shell")
 'Recupero le informazioni dalle chiavi di registro"
 DigitalID = objshell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId")
 ProductName = "Product Name: " & objshell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName")
 ProductID = "Product ID: " & objshell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductID")
 Version= objshell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
 
 If InStr(Win8Version,Version) Then
  'Windows 8 o Windows 8.1
  ProductKey = "Product Key: " & GetKeyWindows8(DigitalID) 
 Else
  If InStr(WinOlderVersion,Version) Then
     ' Windows 7 o antecedente
  ProductKey = "Product Key: " & GetKeyWindows7(DigitalID) 
  Else
     msgBox "Versione di Windows non supportata." & vblf &"Il presente Script è stato testato per versioni di Windows comprese tra Windows 2000 e Windows 8.1" , vbOKOnly+vbCritical, "Versione Windows non supportata"
  ProductKey ="Product Key: Non Rilevato"
     End If   
  
 End If
 
 ProductInfo = ProductName  & vbNewLine & ProductID  & vbNewLine & ProductKey
 'Mostra i dati e chiedi se si intende salvare in un file
 If vbYes = MsgBox(ProductInfo  & vblf & vblf & "Vuoi salvare le informazioni in un file?", vbYesNo + vbQuestion, "Windows Product Key") then
    Save ProductInfo
 End If


'Convert i valori binari della chiave "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId" in caratteri per Windows 8
Function GetKeyWindows8(Key)
    Const KeyOffset = 52
    Dim isWin8, Maps, i, j, Current, KeyOutput, Last, keypart1, insert
    'Check if OS is Windows 8
    isWin8 = (Key(66) \ 6) And 1
    Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
    i = 24
    Maps = "BCDFGHJKMPQRTVWXY2346789"
    Do
        Current= 0
        j = 14
        Do
           Current = Current* 256
           Current = Key(j + KeyOffset) + Current
           Key(j + KeyOffset) = (Current \ 24)
           Current=Current Mod 24
            j = j -1
        Loop While j >= 0
        i = i -1
        KeyOutput = Mid(Maps,Current+ 1, 1) & KeyOutput
        Last = Current
    Loop While i >= 0 
    keypart1 = Mid(KeyOutput, 2, Last)
    insert = "N"
    KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
    If Last = 0 Then KeyOutput = insert & KeyOutput
    GetKeyWindows8 = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
 
End Function
'Converte i valori binari della chiave "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId" in caratteri per Windows 7
Function GetKeyWindows7(ProductID)
    Const KeyOffset = 52
 Dim i, Cur, x, Maps
    i = 0
    Maps = "BCDFGHJKMPQRTVWXY2346789"
    Do
        Cur = 0
        x = 14
  i=i+1
        Do
            Cur = Cur * 256
            Cur = ProductID(x + KeyOffset) + Cur
            ProductID(x + KeyOffset) = (Cur \ 24) And 255
            Cur = Cur Mod 24
            x = x -1
        Loop While x >= 0
  if (i Mod 6) = 0 Then
   ProductKey = "-" & ProductKey
   i = i + 1
  End If  
  ProductKey = Mid(Maps, Cur + 1, 1) & ProductKey   
    Loop While i < 29
    GetKeyWindows7 = ProductKey
End Function

'Salva i dati in un file
Function Save(Data)
    Dim fso, fName, txt,objshell,UserName
    Set objshell = CreateObject("wscript.shell")
    'Crea un file di testo con nome WindowsKeyInfo.txt, nello stesso percorso del vbs, contenente le informazioni
    fName = "WindowsKeyInfo.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txt = fso.CreateTextFile(fName)
    txt.Writeline Data
    txt.Close
End Function

Per chi volesse scaricare il file VBS può utilizzare il link di seguito
DOWNLOAD