Here is a little script to get the office keys.
Should work for office 2000/XP/2003/2007/2010
Dim ScriptHelper
Set ScriptHelper = New ScriptHelperClass
ScriptHelper.RunMeWithCScript()
strComputer = ScriptHelper.Network.ComputerName
CONST HKEY_CLASSES_ROOT = &H80000000
CONST HKEY_CURRENT_USER = &H80000001
CONST HKEY_LOCAL_MACHINE = &H80000002
CONST HKEY_USERS = &H80000003
CONST KEY_QUERY_VALUE = 1
CONST KEY_SET_VALUE = 2
CONST SEARCH_KEY = "DigitalProductID"
Dim arrSubKeys(10,1)
Dim foundKeys
Dim iValues, arrDPID
foundKeys = Array()
iValues = Array()
'Windows
arrSubKeys(0,0) = "Windows PID Key: "
arrSubKeys(0,1) = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
'Office 2010
arrSubKeys(1,0) = "Office 2010 PID Key: "
arrSubKeys(1,1) = "SOFTWARE\Microsoft\Office\14.0\Registration"
arrSubKeys(2,0) = "Office 2010 PID Key: "
arrSubKeys(2,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\14.0\Registration"
'Office 2007
arrSubKeys(3,0) = "Office 2007 PID Key: "
arrSubKeys(3,1) = "SOFTWARE\Microsoft\Office\12.0\Registration"
arrSubKeys(4,0) = "Office 2007 PID Key: "
arrSubKeys(4,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Registration"
'Office 2003
arrSubKeys(5,0) = "Office 2003 PID Key: "
arrSubKeys(5,1) = "SOFTWARE\Microsoft\Office\11.0\Registration"
arrSubKeys(6,0) = "Office 2003 PID Key: "
arrSubKeys(6,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\11.0\Registration"
'Office XP
arrSubKeys(7,0) = "Office XP PID Key: "
arrSubKeys(7,1) = "SOFTWARE\Microsoft\Office\10.0\Registration"
arrSubKeys(8,0) = "Office XP PID Key: "
arrSubKeys(8,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\10.0\Registration"
'Office 2000
arrSubKeys(9,0) = "Office 2000 PID Key: "
arrSubKeys(9,1) = "SOFTWARE\Microsoft\Office\9.0\Registration"
arrSubKeys(10,0) = "Office 2000 PID Key: "
arrSubKeys(10,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\9.0\Registration"
GetKeys()
Public Function GetKeys()
For x = LBound(arrSubKeys, 1) To UBound(arrSubKeys, 1)
ScriptHelper.Registry.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1), SEARCH_KEY, arrDPIDBytes
If Not IsNull(arrDPIDBytes) Then
Call decodeKey(arrDPIDBytes, arrSubKeys(x,0))
Else
ScriptHelper.Registry.EnumKey HKEY_LOCAL_MACHINE, arrSubKeys(x,1), arrGUIDKeys
If Not IsNull(arrGUIDKeys) Then
For Each GUIDKey In arrGUIDKeys
ScriptHelper.Registry.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
End Function
Public Function decodeKey(iValues, strProduct)
Dim arrDPID
arrDPID = Array()
For i = 52 to 66
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
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")
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
End If
Next
ReDim Preserve foundKeys( UBound(foundKeys) + 1 )
foundKeys( UBound(foundKeys) ) = strProductKey
strKey = UBound(foundKeys)
Wscript.Echo " " & strProduct & "" & foundKeys(strKey)
End Function
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'//
'// ScriptHelperClass and EnvironmentClass are helper classes to simplify
'// script work. Declare and use globally throughout the script.
'//
'// Example code:
'//
'// Option Explicit
'// Dim ScriptHelper
'// Set ScriptHelper = New ScriptHelperClass
'// ScriptHelper.RunMeWithCScript()
'// ScriptHelper.ElevateThisScript()
'// WScript.Echo "User profile : " & ScriptHelper.Environment.UserProfile
'// WScript.Echo "Domain : " & ScriptHelper.Network.UserDomain
'// ScriptHelper.CreateFolder "\\SERVER\Share\Folder\With\Path"
'// ScriptHelper.FileSystem.FileExists("C:\command.com")
'// ScriptHelper.Shell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\ProductOptions\ProductType")
'//
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Class ScriptHelperClass
Private objEnvironment
Private objFileSystem
Private objNetwork
Private objShell
Private objSWBemlocator
Private objWMI
Private objRegistry
Private objSWbemDateTime
Public Computer
Public Property Get Environment
If objEnvironment Is Nothing Then
Set objEnvironment = New EnvironmentClass
objEnvironment.Shell = Shell
End If
Set Environment = objEnvironment
End Property
Public Property Get FileSystem
If objFileSystem Is Nothing Then Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set FileSystem = objFileSystem
End Property
Public Property Get Network
If objNetwork Is Nothing Then Set objNetwork = CreateObject("WScript.Network")
Set Network = objNetwork
End Property
Public Property Get Shell
If objShell Is Nothing Then Set objShell = CreateObject("WScript.Shell")
Set Shell = objShell
End Property
Public Property Get WMI
If objWMI Is Nothing Then
On Error Resume Next
Set objSWBemlocator = CreateObject("WbemScripting.SWbemLocator")
Set objWMI = objSWBemlocator.ConnectServer(Computer, "root\CIMV2")
objWMI.Security_.ImpersonationLevel = 3
On Error Goto 0
End If
Set WMI = objWMI
End Property
Public Property Get Registry
If objRegistry Is Nothing Then Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
Set Registry = objRegistry
End Property
Public Property Get SWbemDateTime
If objSWbemDateTime Is Nothing Then Set objSWbemDateTime = CreateObject("WbemScripting.SWbemDateTime")
Set SWbemDateTime = objSWbemDateTime
End Property
Private Sub Class_Initialize()
Computer = "."
Set objEnvironment = Nothing
Set objFileSystem = Nothing
Set objNetwork = Nothing
Set objShell = Nothing
Set objSWBemlocator = Nothing
Set objWMI = Nothing
Set objRegistry = Nothing
Set objSWbemDateTime = Nothing
End Sub
Private Sub Class_Terminate
Set objSWbemDateTime = Nothing
Set objRegistry = Nothing
Set objWMI = Nothing
Set objSWBemlocator = Nothing
Set objShell = Nothing
Set objNetwork = Nothing
Set objFileSystem = Nothing
Set objEnvironment = Nothing
End Sub
Public Property Get ScriptPath()
ScriptPath = FileSystem.GetFile(WScript.ScriptFullName).ParentFolder
End Property
Public Function GetCurrentUserSID()
Dim intCount, colItems, objItem, strSID
Set colItems = WMI.ExecQuery("SELECT * FROM Win32_UserAccount WHERE Name = '" & Network.Username & "' AND Domain = '" & Network.UserDomain & "'", , 48)
intCount = 0
For Each objItem In colItems
strSID = Cstr(objItem.SID)
intCount = intCount + 1
Next
If intCount > 0 Then
GetCurrentUserSID = strSID
Else
GetCurrentUserSID = "NOTFOUND"
End If
End Function
Public Sub CreateFolder(strFldPath)
Dim fldArray, x, intStartIndex, blnUNC, strDestFold : strDestFold = ""
If Left(strFldPath, 2) = "\\" Then
blnUNC = True
intStartIndex = 3 'Start at the first folder in UNC path
Else
blnUNC = False
intStartIndex = 0
End If
fldArray = Split(strFldPath, "\") 'Split folders into array
If fldArray(intStartIndex) = "" Then Exit Sub
For x = intStartIndex To UBound(fldArray)
If strDestFold = "" Then
If blnUNC Then
strDestFold = "\\" & fldArray(x-1) & "\" & fldArray(x) 'Prefix UNC with server and share
Else
strDestFold = fldArray(x)
End If
Else
strDestFold = strDestFold & "\" & fldArray(x) 'Append each folder to end of path
End If
If Not FileSystem.FolderExists(strDestFold) Then FileSystem.CreateFolder(strDestFold)
Next
End Sub
Public Sub DeleteFolder(strFldPath)
If FileSystem.FolderExists(strFldPath) Then FileSystem.DeleteFolder strFldPath, True
End Sub
'//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Subroutine: RunMeWithCScript()
'//
'// Purpose: Forces the currently running script to use Cscript.exe as the Script
'// engine. If the script is already running with cscript.exe the sub exits
'// and continues the script.
'//
'// Sub Attempts to call the script with its original arguments. Arguments
'// that contain a space will be wrapped in double quotes when the script
'// calls itself again. To verify your command string you can echo out the
'// scriptCommand variable.
'//
'// Usage: Add a call to this sub (RunMeWithCscript) to the beggining of your script
'// to ensure that cscript.exe is used as the script engine.
'//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub RunMeWithCScript()
Dim scriptEngine, engineFolder, Args, arg, scriptName, argString, scriptCommand
scriptEngine = Ucase(Mid(Wscript.FullName,InstrRev(Wscript.FullName,"\")+1))
engineFolder = Left(Wscript.FullName,InstrRev(Wscript.FullName,"\"))
argString = ""
If scriptEngine = "WSCRIPT.EXE" Then
Dim Shell : Set Shell = CreateObject("Wscript.Shell")
Set Args = Wscript.Arguments
For each arg in Args 'loop though argument array as a collection to rebuild argument string
If instr(arg," ") > 0 Then arg = """" & arg & """" 'if the argument contains a space wrap it in double quotes
argString = argString & " " & Arg
Next
'Create a persistent command prompt for the cscript output window and call the script with its original arguments
scriptCommand = "cmd.exe /k " & engineFolder & "cscript.exe """ & Wscript.ScriptFullName & """" & argString
Shell.Run scriptCommand,,False
Wscript.Quit
Else
Exit Sub 'Already Running with Cscript Exit this Subroutine
End If
End Sub
'//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Subroutine: ElevateThisScript()
'//
'// Purpose: (Intended for Vista+)
'// Forces the currently running script to prompt for UAC elevation if it
'// detects that the current user credentials do not have administrative
'// privileges.
'//
'// If run on Windows XP this script will cause the RunAs dialog to appear if
'// the user does not have administrative rights, giving the opportunity to
'// run as an administrator.
'//
'// This Sub Attempts to call the script with its original arguments.
'// Arguments that contain a space will be wrapped in double quotes when the
'// script calls itself again.
'//
'// Usage: Add a call to this sub (ElevateThisScript) to the beginning of your
'// script to ensure that the script gets an administrative token.
'//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub ElevateThisScript()
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
const KEY_QUERY_VALUE = 1
Const KEY_SET_VALUE = 2
Dim scriptEngine, engineFolder, argString, arg, Args, scriptCommand, HasRequiredRegAccess
Dim objShellApp : Set objShellApp = CreateObject("Shell.Application")
scriptEngine = Ucase(Mid(Wscript.FullName,InstrRev(Wscript.FullName,"\")+1))
engineFolder = Left(Wscript.FullName,InstrRev(Wscript.FullName,"\"))
argString = ""
Set Args = Wscript.Arguments
For each arg in Args 'loop though argument array as a collection to rebuild argument string
If instr(arg," ") > 0 Then arg = """" & arg & """" 'if the argument contains a space wrap it in double quotes
argString = argString & " " & Arg
Next
scriptCommand = engineFolder & scriptEngine
Dim objReg, bHasAccessRight
Set objReg=GetObject("winmgmts:"_
& "{impersonationLevel=impersonate}!\\" &_
Computer & "\root\default:StdRegProv")
'Check for administrative registry access rights
objReg.CheckAccess HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\CrashControl", _
KEY_SET_VALUE, bHasAccessRight
If bHasAccessRight = True Then
HasRequiredRegAccess = True
Exit Sub
Else
HasRequiredRegAccess = False
objShellApp.ShellExecute scriptCommand, " """ & Wscript.ScriptFullName & """" & argString, "", "runas"
WScript.Quit
End If
End Sub
End Class
Class EnvironmentClass
Private objShell
Private strLogonServer
Private strProgramFiles
Private strProgramFilesX86
Private strUserProfile
Private strWinDir
Public Cache
Public Property Let Shell(objParentShell)
Set objShell = objParentShell
End Property
Public Property Get LogonServer
If IsNull(strLogonServer) Or Cache = False Then strLogonServer = objShell.ExpandEnvironmentStrings("%LOGONSERVER%")
LogonServer = strLogonServer
End Property
Public Property Get ProgramFiles
If IsNull(strProgramFiles) Or Cache = False Then strProgramFiles = objShell.ExpandEnvironmentStrings("%PROGRAMFILES%")
ProgramFiles = strProgramFiles
End Property
Public Property Get ProgramFilesX86
If IsNull(strProgramFilesX86) Or Cache = False Then strProgramFilesX86 = objShell.ExpandEnvironmentStrings("%PROGRAMFILES(x86)%")
ProgramFilesX86 = strProgramFilesX86
End Property
Public Property Get UserProfile
If IsNull(strUserProfile) Or Cache = False Then strUserProfile = objShell.ExpandEnvironmentStrings("%USERPROFILE%")
UserProfile = strUserProfile
End Property
Public Property Get WinDir
If IsNull(strWinDir) Or Cache = False Then strWinDir = objShell.ExpandEnvironmentStrings("%WINDIR%")
WinDir = strWinDir
End Property
Private Sub Class_Initialize()
Cache = True
strLogonServer = Null
strProgramFiles = Null
strProgramFilesX86 = Null
strUserProfile = Null
strWinDir = Null
End Sub
End Class
