Open Notepad. Then copy all the data in the Code box below and paste it into Notepad.
Click File / Save as and save it as "ShowKey.vbs" on the Desktop. Include the double quotes or Notepad will add .txt to the end of the name.
Right click on ShowKey.vbs on the Desktop and select Run as Administrator.
Output is in a window on the Desktop. Click Yes to save it to Windows Key.txt in the same folder Showkeys.vbs is in which in this case should be your Desktop. It would be a good idea to print that file or save it somewhere so when you need it, it's available.
Code:
Set WshShell = CreateObject("WScript.Shell")
Key = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
DigitalID = WshShell.RegRead(key & "DigitalProductId")
ProductName = "Product Name: " & WshShell.RegRead(Key & "ProductName") & vbNewLine
ProductID = "Product ID: " & WshShell.RegRead(Key & "ProductID") & vbNewLine
ProductKey = "Installed Key: " & ConvertToKey(DigitalID)
ProductID = ProductName & ProductID & ProductKey
If vbYes = MsgBox(ProductId & vblf & vblf & "Save to a file?", vbYesNo + vbQuestion, "Windows Key Information") then
Save ProductID
End if
Function ConvertToKey(Key)
Const KeyOffset = 52
isWin8 = (Key(66) \ 6) And 1
Key(66) = (Key(66) And &HF7) Or ((isWin8 And 2) * 4)
i = 24
Chars = "BCDFGHJKMPQRTVWXY2346789"
Do
Cur = 0
X = 14
Do
Cur = Cur * 256
Cur = Key(X + KeyOffset) + Cur
Key(X + KeyOffset) = (Cur \ 24)
Cur = Cur Mod 24
X = X -1
Loop While X >= 0
i = i -1
KeyOutput = Mid(Chars, Cur + 1, 1) & KeyOutput
Last = Cur
Loop While i >= 0
If (isWin8 = 1) Then
keypart1 = Mid(KeyOutput, 2, Last)
insert = "N"
KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
If Last = 0 Then KeyOutput = insert & KeyOutput
End If
a = Mid(KeyOutput, 1, 5)
b = Mid(KeyOutput, 6, 5)
c = Mid(KeyOutput, 11, 5)
d = Mid(KeyOutput, 16, 5)
e = Mid(KeyOutput, 21, 5)
ConvertToKey = a & "-" & b & "-" & c & "-" & d & "-" & e
End Function
Function Save(Data)
Const ForWRITING = 2
Const asASCII = 0
Dim fso, f, fName, ts
fName = "Windows Key.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile fName
Set f = fso.GetFile(fName)
Set f = f.OpenAsTextStream(ForWRITING, asASCII)
f.Writeline Data
f.Close
End Function
Script posted by NiFu here: How do I find my Product Key?