Skip to content

Instantly share code, notes, and snippets.

@Sriram-PR

Sriram-PR/GetWindowsProductKey.vbs

Last active March 6, 2025 15:43
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save Sriram-PR/8329dc5aadd489de24ae7a2aba04bf04 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save Sriram-PR/8329dc5aadd489de24ae7a2aba04bf04 to your computer and use it in GitHub Desktop.
Download ZIP
Retrieve Windows Product Key
Raw
GetWindowsProductKey.vbs
' VBScript utility to extract Windows product keys and activation status across Windows 7/8/10/11.
' Uses multiple fallback methods (WMI, PowerShell, Registry) for maximum compatibility with KMS, OEM, and retail licenses.
' Displays results in a dialog and optionally saves to disk.
' Requires admin rights.
Option Explicit
' Variables for WMI, registry access, and data storage
Dim objshell, path, DigitalID, Result
Dim ProductName, ProductID, ProductKey, ProductData
Dim isWin8OrNewer, WinVer
Dim fso, logPath
Dim KeySource ' Identifies which retrieval method succeeded
' Create shell object for registry access and environment variables
' Must be initialized first as other objects depend on it
On Error Resume Next
Set objshell = CreateObject("WScript.Shell")
If Err.Number <> 0 Then
MsgBox "Error creating WScript.Shell object: " & Err.Description, vbCritical, "Error"
WScript.Quit
End If
On Error GoTo 0
' Initialize FileSystemObject and set log directory to %SystemDrive%\Logs
Set fso = CreateObject("Scripting.FileSystemObject")
logPath = objshell.ExpandEnvironmentStrings("%SystemDrive%") & "\Logs\"
On Error Resume Next
If Not fso.FolderExists(logPath) Then
fso.CreateFolder(logPath)
If Err.Number <> 0 Then
MsgBox "Unable to create " & logPath & " folder: " & Err.Description & vbNewLine & _
"Please run this script as administrator.", vbExclamation
Set fso = Nothing
Set objshell = Nothing
WScript.Quit
End If
End If
On Error GoTo 0
LogAction "Script started"
' Verify administrative privileges - required for registry and WMI access
If Not IsAdmin() Then
MsgBox "This script requires administrator rights to read license information and create folders." & vbNewLine & _
"Please right-click the script and select 'Run as administrator'.", vbExclamation, "Administrator Rights Required"
LogAction "Script terminated - insufficient privileges"
Set fso = Nothing
Set objshell = Nothing
WScript.Quit
End If
LogAction "Running with administrator privileges"
' Set registry path for Windows product information
Path = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\"
' Detect Windows version to apply appropriate key extraction algorithm
' Windows 8+ uses a different algorithm than earlier versions
On Error Resume Next
WinVer = objshell.RegRead(Path & "CurrentBuild")
If Err.Number <> 0 Then
LogAction "Warning: Could not determine Windows version - " & Err.Description
WinVer = 0
End If
isWin8OrNewer = (CDbl(WinVer) >= 9200)
LogAction "Windows Build: " & WinVer & " (Windows 8 or newer: " & isWin8OrNewer & ")"
On Error GoTo 0
' Extract basic product information from registry
On Error Resume Next
ProductName = "Product Name: " & objshell.RegRead(Path & "ProductName")
If Err.Number <> 0 Then ProductName = "Product Name: Unknown"
ProductID = "Product ID: " & objshell.RegRead(Path & "ProductID")
If Err.Number <> 0 Then ProductID = "Product ID: Unknown"
On Error GoTo 0
' Retrieve product key using the most reliable method available for this Windows version
ProductKey = "Installed Key: " & GetCurrentProductKey()
' Add activation status if available through WMI
On Error Resume Next
Dim ActivationStatus
ActivationStatus = GetActivationStatus()
If ActivationStatus <> "" Then
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey & vbNewLine & ActivationStatus
Else
ProductData = ProductName & vbNewLine & ProductID & vbNewLine & ProductKey
End If
On Error GoTo 0
' Add source information to help with troubleshooting
ProductData = ProductData & vbNewLine & vbNewLine & "Key retrieval method: " & KeySource
' Display results to user
MsgBox ProductData, vbInformation, "Windows License Information"
' Offer to save the license information to a file
Dim savePath
savePath = logPath & "WindowsLicenseInfo.txt"
If vbYes = MsgBox("Do you want to save this information to:" & vbNewLine & savePath & "?", vbYesNo + vbQuestion, "Save License Information") Then
' Try primary save method first
Dim saveSuccess
saveSuccess = False
On Error Resume Next
SaveToLogs ProductData
If Err.Number = 0 Then
saveSuccess = True
Else
LogAction "Regular save failed with error: " & Err.Description
Err.Clear
End If
On Error GoTo 0
' Fall back to alternative save method if primary method fails
If Not saveSuccess Then
LogAction "Trying direct command save method"
SaveWithDirectCommand ProductData
End If
Else
LogAction "User chose not to save the license information"
End If
LogAction "Script completed successfully"
' Release resources to prevent memory leaks
Set fso = Nothing
Set objshell = Nothing
' Function: SaveToLogs
' Purpose: Save license data to text file with timestamp if file already exists
' Returns: None, but raises error on failure
Function SaveToLogs(Data)
On Error Resume Next
Dim fName, txt
fName = logPath & "WindowsLicenseInfo.txt"
LogAction "Attempting to save to: " & fName
' Use timestamped filename to preserve historical data
If fso.FileExists(fName) Then
Dim timestamp
timestamp = Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & "_" & _
Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2)
fName = logPath & "WindowsLicenseInfo_" & timestamp & ".txt"
LogAction "File already exists, creating timestamped version: " & fName
End If
' Write data to file
Set txt = fso.CreateTextFile(fName, True)
If Err.Number <> 0 Then
LogAction "Error creating file: " & Err.Description
' No cleanup needed for txt as it wasn't created
Err.Raise Err.Number ' Re-raise error for caller to handle
Exit Function
End If
txt.WriteLine Data
If Err.Number <> 0 Then
LogAction "Error writing to file: " & Err.Description
txt.Close
Set txt = Nothing
Err.Raise Err.Number ' Re-raise error for caller to handle
Exit Function
End If
txt.Close
Set txt = Nothing
' Notify user and open file
MsgBox "Information saved to:" & vbNewLine & fName, vbInformation, "Save Successful"
LogAction "Information saved to: " & fName
' Open file in Notepad for immediate viewing
objshell.Run "notepad.exe """ & fName & """", 1, False
On Error GoTo 0
End Function
' Function: SaveWithDirectCommand
' Purpose: Alternative save method using CMD when direct file operations fail
' Returns: None
Sub SaveWithDirectCommand(Data)
On Error Resume Next
Dim cmdText, i, line, lines
Dim saveFile
saveFile = logPath & "WindowsLicenseInfo.txt"
LogAction "Attempting to save with direct command to: " & saveFile
' Split data into lines for batch processing
lines = Split(Data, vbNewLine)
' Create temporary command file in user's temp directory
Dim cmdFile
cmdFile = objshell.ExpandEnvironmentStrings("%TEMP%") & "\SaveLicense.cmd"
' Build batch file to write data line by line
Set cmdText = fso.CreateTextFile(cmdFile, True)
If Err.Number <> 0 Then
LogAction "Failed to create command file: " & Err.Description
MsgBox "Cannot create temporary files needed for save operation.", vbCritical, "Save Failed"
Exit Sub
End If
cmdText.WriteLine "@echo off"
cmdText.WriteLine "echo. > """ & saveFile & """" ' Create/clear the file
' Add each line of data to batch file
For i = 0 To UBound(lines)
line = lines(i)
If Trim(line) <> "" Then
cmdText.WriteLine "echo " & line & " >> """ & saveFile & """"
Else
cmdText.WriteLine "echo. >> """ & saveFile & """"
End If
Next
cmdText.Close
Set cmdText = Nothing
' Execute batch file with hidden window
objshell.Run "cmd /c """ & cmdFile & """", 0, True
' Verify success and notify user
If fso.FileExists(saveFile) Then
MsgBox "Information saved to:" & vbNewLine & saveFile, vbInformation, "Save Successful"
LogAction "Successfully saved to: " & saveFile
' Open file in Notepad for immediate viewing
objshell.Run "notepad.exe """ & saveFile & """", 1, False
Else
MsgBox "Could not save information to file using alternate method.", vbCritical, "Save Failed"
LogAction "Failed to save with direct command approach"
End If
' Clean up temporary batch file
On Error Resume Next
If fso.FileExists(cmdFile) Then
fso.DeleteFile cmdFile, True
End If
On Error GoTo 0
End Sub
' Function: GetCurrentProductKey
' Purpose: Try multiple methods to retrieve Windows product key
' Returns: String containing the product key or error message
Function GetCurrentProductKey()
On Error Resume Next
Dim objWMI, colItems, objItem, ProductKey, returnValue
LogAction "Attempting to retrieve product key..."
' Method 1: SoftwareLicensingService WMI (Windows 8/10/11)
' Most reliable for modern Windows versions with digital licensing
Set objWMI = GetObject("winmgts:\\.\root\cimv2")
If Err.Number = 0 Then
Set colItems = objWMI.ExecQuery("SELECT * FROM SoftwareLicensingService")
If Err.Number = 0 Then
For Each objItem in colItems
' Try KMS key first (Volume licensing)
If objItem.KeyManagementServiceProductKeyID <> "" Then
returnValue = objItem.KeyManagementServiceProductKeyID
If Len(returnValue) > 5 Then
LogAction "Retrieved KMS key from SoftwareLicensingService"
KeySource = "KMS Product Key (SoftwareLicensingService WMI)"
GetCurrentProductKey = FormatKey(returnValue)
Set colItems = Nothing
Set objWMI = Nothing
Exit Function
End If
End If
' Try OEM key (Preinstalled Windows)
If objItem.OA3xOriginalProductKey <> "" Then
returnValue = objItem.OA3xOriginalProductKey
If Len(returnValue) > 5 Then
LogAction "Retrieved OEM key from SoftwareLicensingService"
KeySource = "OEM Product Key (SoftwareLicensingService WMI)"
GetCurrentProductKey = returnValue
Set colItems = Nothing
Set objWMI = Nothing
Exit Function
End If
End If
Next
End If
End If
' Clean up resources from Method 1
If Not colItems Is Nothing Then Set colItems = Nothing
If Not objWMI Is Nothing Then Set objWMI = Nothing
Err.Clear
' Method 2: MDM WMI namespace (Some OEM devices)
' Used primarily for MDM-managed devices (Intune, etc.)
Set objWMI = GetObject("winmgmts:\\.\root\CIMV2\mdm\dmmap")
If Err.Number = 0 Then
Set colItems = objWMI.ExecQuery("Select * From Mdm_SoftwareLicensingService")
If Err.Number = 0 Then
For Each objItem in colItems
If objItem.OA3xOriginalProductKey <> "" Then
returnValue = objItem.OA3xOriginalProductKey
If Len(returnValue) > 5 Then
LogAction "Retrieved OEM key from Mdm_SoftwareLicensingService"
KeySource = "OEM Product Key (MDM WMI)"
GetCurrentProductKey = returnValue
Set colItems = Nothing
Set objWMI = Nothing
Exit Function
End If
End If
Next
End If
End If
' Clean up resources from Method 2
If Not colItems Is Nothing Then Set colItems = Nothing
If Not objWMI Is Nothing Then Set objWMI = Nothing
Err.Clear
' Method 3: PowerShell command for OEM key
' Some systems expose keys only via PowerShell
Dim psCmd
psCmd = "powershell -command ""& {(Get-WmiObject -query 'select * from SoftwareLicensingService').OA3xOriginalProductKey}"""
returnValue = Trim(objShell.Exec(psCmd).StdOut.ReadAll())
If Err.Number = 0 And Len(returnValue) > 5 Then
LogAction "Retrieved product key via PowerShell command"
KeySource = "OEM Product Key (PowerShell)"
GetCurrentProductKey = returnValue
Exit Function
End If
Err.Clear
' Method 4: PowerShell for partial key
' When full key isn't available, try last 5 chars
psCmd = "powershell -command ""& {(Get-WmiObject -query 'select * from SoftwareLicensingService').PartialProductKey}"""
returnValue = Trim(objShell.Exec(psCmd).StdOut.ReadAll())
If Err.Number = 0 And Len(returnValue) > 0 Then
LogAction "Retrieved partial product key via PowerShell command"
KeySource = "Partial Product Key (last 5 characters)"
GetCurrentProductKey = "[Last 5 characters: " & returnValue & "]"
Exit Function
End If
Err.Clear
' Method 5: slmgr.vbs command line tool
' Built-in Windows script for license management
LogAction "Trying to extract key from slmgr /dli output"
psCmd = "cscript //nologo %windir%\system32\slmgr.vbs /dli"
Dim slmgrOutput, keyPos, keyLine, parts
slmgrOutput = objShell.Exec(psCmd).StdOut.ReadAll()
If Err.Number = 0 And InStr(slmgrOutput, "Product Key:") > 0 Then
keyPos = InStr(slmgrOutput, "Product Key:")
keyLine = Mid(slmgrOutput, keyPos, InStr(keyPos, slmgrOutput, vbCrLf) - keyPos)
parts = Split(keyLine, "-")
If UBound(parts) >= 0 Then
returnValue = "[Partial Key from slmgr: " & parts(UBound(parts)) & "]"
LogAction "Retrieved partial key from slmgr /dli output"
KeySource = "slmgr /dli command"
GetCurrentProductKey = returnValue
Exit Function
End If
End If
Err.Clear
' Method 6: Legacy registry method (Last resort)
' Works on older Windows versions using binary conversion
LogAction "All WMI methods failed, falling back to registry method"
returnValue = ConvertToKey(objshell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductId"))
If returnValue <> "" And returnValue <> "Error converting product key" Then
KeySource = "Registry DigitalProductId (legacy method)"
GetCurrentProductKey = returnValue
Else
KeySource = "No valid product key found"
GetCurrentProductKey = "No valid product key could be found"
End If
On Error GoTo 0
End Function
' Function: GetActivationStatus
' Purpose: Retrieve Windows activation status from WMI
' Returns: String with activation status or empty string if unavailable
Function GetActivationStatus()
On Error Resume Next
Dim objWMI, colItems, objItem, status
Set objWMI = GetObject("winmgts:\\.\root\cimv2")
Set colItems = objWMI.ExecQuery("SELECT * FROM SoftwareLicensingProduct WHERE LicenseStatus > 0")
If Err.Number = 0 Then
For Each objItem in colItems
' Convert numeric status to human-readable form
Select Case objItem.LicenseStatus
Case 0: status = "Unlicensed"
Case 1: status = "Licensed"
Case 2: status = "Out-of-Box Grace Period"
Case 3: status = "Out-of-Tolerance Grace Period"
Case 4: status = "Non-Genuine Grace Period"
Case 5: status = "Notification"
Case 6: status = "Extended Grace"
Case Else: status = "Unknown Status: " & objItem.LicenseStatus
End Select
GetActivationStatus = "Activation Status: " & status
' Clean up resources before exit
Set colItems = Nothing
Set objWMI = Nothing
Exit Function
Next
End If
' Clean up resources
If Not colItems Is Nothing Then Set colItems = Nothing
If Not objWMI Is Nothing Then Set objWMI = Nothing
GetActivationStatus = ""
On Error GoTo 0
End Function
' Function: FormatKey
' Purpose: Format product key with dashes for readability
' Returns: Formatted product key string
Function FormatKey(rawKey)
If Len(rawKey) = 25 Then
' Standard 25-character key, add dashes
FormatKey = Mid(rawKey, 1, 5) & "-" & Mid(rawKey, 6, 5) & "-" & Mid(rawKey, 11, 5) & "-" & Mid(rawKey, 16, 5) & "-" & Mid(rawKey, 21, 5)
ElseIf Len(rawKey) = 29 Then
' Already formatted with dashes
FormatKey = rawKey
Else
' Non-standard length, return as-is
FormatKey = rawKey
End If
End Function
' Function: ConvertToKey
' Purpose: Convert binary registry data to product key string
' Used for legacy Windows versions where WMI methods aren't available
' Algorithm sourced from Microsoft documentation
Function ConvertToKey(Key)
On Error Resume Next
' Validate key data
If IsNull(Key) Then
ConvertToKey = "Error reading registry key"
Exit Function
End If
Const KeyOffset = 52
Dim Maps, i, j, Current, KeyOutput, Last, keypart1, insert
' Apply different algorithm based on Windows version
If isWin8OrNewer Then
' Windows 8/10/11 algorithm
Key(66) = (Key(66) And &HF7) Or 8
Else
' Pre-Windows 8 algorithm
Key(66) = (Key(66) And &HF7) Or 0
End If
i = 24
Maps = "BCDFGHJKMPQRTVWXY2346789"
KeyOutput = ""
' Decode binary data to character string
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
' Insert 'N' character at specific position (part of algorithm)
keypart1 = Mid(KeyOutput, 2, Last)
insert = "N"
KeyOutput = Replace(KeyOutput, keypart1, keypart1 & insert, 2, 1, 0)
If Last = 0 Then KeyOutput = insert & KeyOutput
' Format key with standard hyphenation
ConvertToKey = Mid(KeyOutput, 1, 5) & "-" & Mid(KeyOutput, 6, 5) & "-" & Mid(KeyOutput, 11, 5) & "-" & Mid(KeyOutput, 16, 5) & "-" & Mid(KeyOutput, 21, 5)
If Err.Number <> 0 Then
LogAction "Error in ConvertToKey function: " & Err.Description
ConvertToKey = "Error converting product key"
End If
On Error GoTo 0
End Function
' Function: IsAdmin
' Purpose: Check if script is running with administrator privileges
' Returns: Boolean indicating admin status
Function IsAdmin()
On Error Resume Next
Dim adminShell
Set adminShell = CreateObject("WScript.Shell")
' Try to access a registry key that requires admin rights
adminShell.RegRead "HKEY_USERS\S-1-5-19\Environment\TEMP"
IsAdmin = (Err.Number = 0)
Set adminShell = Nothing
On Error GoTo 0
End Function
' Function: LogAction
' Purpose: Write timestamped entries to log file
' Returns: None
Sub LogAction(Message)
On Error Resume Next
Dim logFile, logFileName
logFileName = logPath & "WindowsLicenseRetrieval.log"
' Try to open existing log file or create new one
Set logFile = fso.OpenTextFile(logFileName, 8, True)
If Err.Number <> 0 Then
' 8 = ForAppending, True = Create if doesn't exist
Err.Clear
Set logFile = fso.CreateTextFile(logFileName, True)
If Err.Number <> 0 Then
Set logFile = Nothing
Exit Sub ' Can't create log, silently fail
End If
End If
' Write timestamped message
logFile.WriteLine Now & " - " & Message
logFile.Close
Set logFile = Nothing
On Error GoTo 0
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment