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 |
