Scripting Retrieval  of Office & Windows Product Keys

The following scripts will work on Windows 2000 & higher, and only Office 2003 to find the product keys and create a text document with the product name & product key.

Create the following 2 .vbs files to, modifying the lines in bold to point to the shared drive you want to dump the results, and then create a batch files with the following lines:

cscript x:\scripts\windowskey.vbs
cscript x:\scripts\officekey.vbs

Have your login script run this batch file upon login and have your users log off and back on to create the text documents with the product keys.

Save this file as office.vbs

Public Function sGetXPCDKey()

Dim bDigitalProductID
Dim bProductKey()
Dim bKeyChars(24)
Dim ilByte
Dim nCur
Dim sCDKey
Dim ilKeyByte
Dim ilBit

ReDim Preserve bProductKey(14)

Set objShell = CreateObject("WScript.Shell")

bDigitalProductID = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration\{91110409-6000-11D3-8CFE-0150048383C9}\DigitalProductID")

Set objShell = Nothing

For ilByte = 52 To 66
bProductKey(ilByte - 52) = bDigitalProductID(ilByte)
Next

'Possible characters in the CD Key:
bKeyChars(0) = Asc("B")
bKeyChars(1) = Asc("C")
bKeyChars(2) = Asc("D")
bKeyChars(3) = Asc("F")
bKeyChars(4) = Asc("G")
bKeyChars(5) = Asc("H")
bKeyChars(6) = Asc("J")
bKeyChars(7) = Asc("K")
bKeyChars(8) = Asc("M")
bKeyChars(9) = Asc("P")
bKeyChars(10) = Asc("Q")
bKeyChars(11) = Asc("R")
bKeyChars(12) = Asc("T")
bKeyChars(13) = Asc("V")
bKeyChars(14) = Asc("W")
bKeyChars(15) = Asc("X")
bKeyChars(16) = Asc("Y")
bKeyChars(17) = Asc("2")
bKeyChars(18) = Asc("3")
bKeyChars(19) = Asc("4")
bKeyChars(20) = Asc("6")
bKeyChars(21) = Asc("7")
bKeyChars(22) = Asc("8")
bKeyChars(23) = Asc("9")

For ilByte = 24 To 0 Step -1

nCur = 0

For ilKeyByte = 14 To 0 Step -1
'Step through each byte in the Product Key
nCur = nCur * 256 Xor bProductKey(ilKeyByte)
bProductKey(ilKeyByte) = Int(nCur / 24)
nCur = nCur Mod 24
Next

sCDKey = Chr(bKeyChars(nCur)) & sCDKey
If ilByte Mod 5 = 0 And ilByte <> 0 Then sCDKey = "-" & sCDKey
Next

sGetXPCDKey = sCDKey


End Function

Public Function Question()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim strUserName
Dim strCompName
Dim objNetwork
Dim sGetOfficePID
Dim sGetOfficePName

Set objShell = CreateObject("WScript.Shell")

sGetOfficePID = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration\{91110409-6000-11D3-8CFE-0150048383C9}\ProductID")

sGetOfficePName = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\11.0\Registration\{91110409-6000-11D3-8CFE-0150048383C9}\ProductName")

Set objNetwork = WScript.CreateObject("WScript.Network")

strUserName = objNetwork.UserName
strCompName = objNetwork.ComputerName

Set oOutFile = objFSO.CreateTextFile("x:\scripts\results\" & strUserName & "." & strCompName & "-office.txt")

oOutFile.WriteLine "Licensing for:" & strCompName
oOutFile.WriteLine ""
oOutFile.WriteLine "Office Version"
oOutFile.WriteLine sGetOfficePName
oOutFile.WriteLine ""
oOutFile.WriteLine "Office Product Key"
oOutFile.WriteLine sGetXPCDKey
oOutFile.WriteLine ""
oOutFile.WriteLine "Office Product ID"
oOutFile.WriteLine sGetOfficePID

End Function

call Question

'----------------------------------

Save this file as windows.vbs

Public Function sGetXPCDKey()

Dim bDigitalProductID
Dim bProductKey()
Dim bKeyChars(24)
Dim ilByte
Dim nCur
Dim sCDKey
Dim ilKeyByte
Dim ilBit

ReDim Preserve bProductKey(14)

Set objShell = CreateObject("WScript.Shell")

bDigitalProductID = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\DigitalProductID")

Set objShell = Nothing

For ilByte = 52 To 66
bProductKey(ilByte - 52) = bDigitalProductID(ilByte)
Next

'Possible characters in the CD Key:
bKeyChars(0) = Asc("B")
bKeyChars(1) = Asc("C")
bKeyChars(2) = Asc("D")
bKeyChars(3) = Asc("F")
bKeyChars(4) = Asc("G")
bKeyChars(5) = Asc("H")
bKeyChars(6) = Asc("J")
bKeyChars(7) = Asc("K")
bKeyChars(8) = Asc("M")
bKeyChars(9) = Asc("P")
bKeyChars(10) = Asc("Q")
bKeyChars(11) = Asc("R")
bKeyChars(12) = Asc("T")
bKeyChars(13) = Asc("V")
bKeyChars(14) = Asc("W")
bKeyChars(15) = Asc("X")
bKeyChars(16) = Asc("Y")
bKeyChars(17) = Asc("2")
bKeyChars(18) = Asc("3")
bKeyChars(19) = Asc("4")
bKeyChars(20) = Asc("6")
bKeyChars(21) = Asc("7")
bKeyChars(22) = Asc("8")
bKeyChars(23) = Asc("9")

For ilByte = 24 To 0 Step -1

nCur = 0

For ilKeyByte = 14 To 0 Step -1
'Step through each byte in the Product Key
nCur = nCur * 256 Xor bProductKey(ilKeyByte)
bProductKey(ilKeyByte) = Int(nCur / 24)
nCur = nCur Mod 24
Next

sCDKey = Chr(bKeyChars(nCur)) & sCDKey
If ilByte Mod 5 = 0 And ilByte <> 0 Then sCDKey = "-" & sCDKey
Next

sGetXPCDKey = sCDKey


End Function

Public Function Question()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim strUserName
Dim strCompName
Dim objNetwork
Dim SGetWindowsName
Dim SGetWindowsPID

Set objShell = CreateObject("WScript.Shell")

SGetWindowsPID = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductID")

SGetWindowsName = objShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName")

Set objNetwork = WScript.CreateObject("WScript.Network")

strUserName = objNetwork.UserName
strCompName = objNetwork.ComputerName

Set oOutFile = objFSO.CreateTextFile("x:\scripts\results\" & strUserName & "." & strCompName & "-windows.txt")

oOutFile.WriteLine "Licensing for:" & strCompName
oOutFile.WriteLine ""
oOutFile.WriteLine "Windows Version"
oOutFile.WriteLine SGetWindowsName
oOutFile.WriteLine ""
oOutFile.WriteLine "Windows Product Key"
oOutFile.WriteLine sGetXPCDKey
oOutFile.WriteLine ""
oOutFile.WriteLine "Windows Product ID"
oOutFile.WriteLine SGetWindowsPID


End Function

call Question

'----------------------------------