' Getting Microsoft Office Product ID and Produck(license key) key installed on a local computer
' Tested on Windows XP(32 bit), Windows 7 (32 bit)
' Author: Ruzanna Martirosyan
If err.number <> 0 Then
WScript.Echo ("Script Check Failed")
Wscript.Quit 1001
Else
Const HKEY_LOCAL_MACHINE = &H80000002
Dim arrayID(5,1)
arrayID(0,0) = "97"
arrayID(0,1) = "8.0"
arrayID(1,0) = "2000"
arrayID(1,1) = "9.0"
arrayID(2,0) = "XP"
arrayID(2,1) = "10.0"
arrayID(3,0) = "2003"
arrayID(3,1) = "11.0"
arrayID(4,0) = "2007"
arrayID(4,1) = "12.0"
arrayID(5,0) = "2010"
arrayID(5,1) = "14.0"
strComputer = "."
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessors = objWMIService.ExecQuery("Select * from Win32_Processor")
For Each objProcessor in colProcessors
Select Case objProcessor.AddressWidth
Case 32 path= "SOFTWARE\Microsoft\Office\"
OSType = 32
Case 64 path="SOFTWARE\Wow6432Node\Microsoft\Office\"
OSType = 64
End Select
next
For a = 0 To 5
searchKey path & arrayID(a,1) & "\Registration", true
Next
Sub searchKey(regKey, bitOS)
oReg.GetBinaryValue HKEY_LOCAL_MACHINE, regKey, "DigitalProductID", Bytes
If IsNull(Bytes) Then
oReg.EnumKey HKEY_LOCAL_MACHINE, regKey, Keys
If Not IsNull(Keys) Then
For Each ForKey In Keys
searchKey regKey & "\" & ForKey, bitOS
Next
End If
Else
foundKey = returnKey(Bytes)
' for 32/64 bit
If bitOS Then
oReg.GetStringValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office\" & arrayID(a,1) & oVer
Else
oReg.GetStringValue HKEY_LOCAL_MACHINE, "SOFTWARE\Wow6432Node\Microsoft\Office\" & arrayID(a,1) & oVer
End If
oReg.GetStringValue HKEY_LOCAL_MACHINE, regKey, "ProductID", foundID
foundBit = OSType
writeout foundID,foundKey,foundBit
End If
End Sub
Sub writeout(foundID,foundKey,foundBit)
If Not IsNull(foundID) Then
Wscript.Echo "Product id is " & foundID & vbNewLine & _
"Key is " & foundKey & vbNewLine & "Architectures is " & foundBit & " bit"
Else
Wscript.echo ("Not found microsoft office")
End If
End Sub
Function returnKey(iValues)
Dim arrDPID, foundKeys
arrDPID = Array()
foundKeys = 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
Next
ReDim Preserve foundKeys( UBound(foundKeys) + 1 )
foundKeys( UBound(foundKeys) ) = strProductKey
strKey = UBound(foundKeys)
returnKey = foundKeys(strKey)
End Function
Wscript.Echo "Successfully Passed"
wscript.Quit(0)
End If
