Blog

Extract Office Install Key (2000/XP/2003/2007/2010)

Here is a little script to get the office keys.
Should work for office 2000/XP/2003/2007/2010

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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
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

Posted in: Scripts, Technical

Leave a Comment (1) ↓

1 Comment

  1. Tony Roberts November 24, 2014

    Trying to get the o work for last couple of days with GFI Max Reote. but unable to do so, just returns invalid script arguments, I have also tried to run from a cmd prompt on 3 test machines, but it fails to run I have copied and pasted using notepad and have used same procedure for all your other scripts, they all work without issue

    Thanks

    reply

Leave a Comment