1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
|
On Error Resume Next
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
arrComputers = Array("localhost")
For Each strComputer In arrComputers
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_ComputerSystemProduct", "WQL", _
wbemFlagReturnImmediately + wbemFlagForwardOnly)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_ComputerSystem", "WQL", _
wbemFlagReturnImmediately + wbemFlagForwardOnly)
Next
CONST HKEY_LOCAL_MACHINE = &H80000002
CONST SEARCH_KEY = "DigitalProductID"
Dim arrSubKeys(7,1)
Dim foundKeys
Dim iValues, arrDPID
foundKeys = Array()
iValues = Array()
arrSubKeys(0,0) = "Office2010"
arrSubKeys(0,1) = "SOFTWARE\Microsoft\Office\14.0\Registration"
arrSubKeys(1,0) = "Office2010"
arrSubKeys(1,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\14.0\Registration"
arrSubKeys(2,0) = "Office2007"
arrSubKeys(2,1) = "SOFTWARE\Microsoft\Office\12.0\Registration"
arrSubKeys(3,0) = "Office2007"
arrSubKeys(3,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Registration"
arrSubKeys(4,0) = "OfficeXP"
arrSubKeys(4,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\10.0\Registration"
arrSubKeys(5,0) = "OfficeXP"
arrSubKeys(5,1) = "SOFTWARE\Microsoft\Office\10.0\Registration"
arrSubKeys(6,0) = "Office2003"
arrSubKeys(6,1) = "SOFTWARE\Wow6432Node\Microsoft\Office\11.0\Registration"
arrSubKeys(7,0) = "Office2003"
arrSubKeys(7,1) = "SOFTWARE\Microsoft\Office\11.0\Registration"
strComputer = "."
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
For x = LBound(arrSubKeys, 1) To UBound(arrSubKeys, 1)
oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1), SEARCH_KEY, arrDPIDBytes
If Not IsNull(arrDPIDBytes) Then
If (x<2) Then
call decodeKey2(arrDPIDBytes, arrSubKeys(x,0))
Else
call decodeKey1(arrDPIDBytes, arrSubKeys(x,0))
End If
Else
oReg.EnumKey HKEY_LOCAL_MACHINE, arrSubKeys(x,1), arrGUIDKeys
If Not IsNull(arrGUIDKeys) Then
For Each GUIDKey In arrGUIDKeys
oReg.GetBinaryValue HKEY_LOCAL_MACHINE, arrSubKeys(x,1) & "\" & GUIDKey, SEARCH_KEY, arrDPIDBytes
If Not IsNull(arrDPIDBytes) Then
If (x<2) Then
call decodeKey2(arrDPIDBytes, arrSubKeys(x,0))
Else
call decodeKey1(arrDPIDBytes, arrSubKeys(x,0))
End If
End If
Next
End If
End If
Next
Function decodeKey1(iValues, strProduct)
Dim arrDPID
arrDPID = Array()
' <--------------- extract bytes 52-66 of the DPID -------------------------->
For i = 52 to 66
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
' <--------------- Create an array to hold the valid characters for a microsoft -------------------------->
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")
' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
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)
'' write output data inserted in XML'
Wscript.Echo "<OFFICEPACK>"
Wscript.Echo "<OFFICEKEY>" & foundKeys(strKey)& "</OFFICEKEY>"
Wscript.Echo "<OFFICEVERSION>" & strProduct & "</OFFICEVERSION>"
Wscript.Echo "</OFFICEPACK>"
End Function
Function decodeKey2(iValues, strProduct)
Dim arrDPID
arrDPID = Array()
' <--------------- extract bytes 52-66 of the DPID -------------------------->
For i = 808 to 822
ReDim Preserve arrDPID( UBound(arrDPID) + 1 )
arrDPID( UBound(arrDPID) ) = iValues(i)
Next
' <--------------- Create an array to hold the valid characters for a microsoft -------------------------->
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")
' <--------------- The clever bit !!! (decode the base24 encoded binary data)-------------------------->
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)
'' write output data inserted in XML'
Wscript.Echo "<OFFICEPACK>"
Wscript.Echo "<OFFICEKEY>" & foundKeys(strKey)& "</OFFICEKEY>"
Wscript.Echo "<OFFICEVERSION>" & strProduct & "</OFFICEVERSION>"
Wscript.Echo "</OFFICEPACK>"
End Function |
Partager