Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Const HKLM = &H80000002
- dim fso: set fso = CreateObject("Scripting.FileSystemObject")
- dim CurrentDirectory
- CurrentDirectory = fso.GetAbsolutePathName(".")
- ' Create the wshNetwork object to pull username
- Set objNetwork = CreateObject("Wscript.Network")
- ' Place keys in $CURRENT_DIR\OfficeKeys.txt == default
- Set objFileToWrite = CreateObject("Scripting.FileSystemObject").OpenTextFile(CurrentDirectory & "\" & objNetwork.UserName & "_OfficeKeys.txt",8,True)
- ' Place keys in $CURRENT_USER\Desktop\OfficeKeys.txt
- 'Set objFileToWrite = CreateObject("Scripting.FileSystemObject").OpenTextFile(CreateObject("WScript.Shell").ExpandEnvironmentStrings("%UserProfile%") & "\Desktop\OfficeKeys.txt",8,True)
- 'wscript.echo "View Product Keys | Microsoft Products" & vbCrLf
- 'Install Date
- Computer = "."
- Set objWMIService = GetObject("winmgmts:\\" & Computer & "\root\cimv2")
- Set Obj = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
- dim InsDate
- For Each item in Obj
- InsDate = item.InstallDate
- ' Gather Operating System Information
- Caption = Item.Caption
- OSArchitecture = Item.OSArchitecture
- CSDVersion = Item.CSDVersion
- Version = Item.Version
- Next
- dim NewDate
- NewDate = mid(InsDate,9,2) & ":" & mid(InsDate,11,2) & ":" & mid(InsDate,13,2)
- NewDate = NewDate & " " & mid(InsDate,7,2) & "/" & mid(InsDate,5,2) & "/" & mid(InsDate,1,4)
- QueryWindowsProductKeys()
- 'wscript.echo 'vbCrLf & "Office Keys" & vbCrLf
- QueryOfficeProductKeys()
- Function DecodeProductKey(arrKey, intKeyOffset)
- If Not IsArray(arrKey) Then Exit Function
- intIsWin8 = BitShiftRight(arrKey(intKeyOffset + 14),3) And 1
- arrKey(intKeyOffset + 14) = arrKey(intKeyOffset + 14) And 247 Or BitShiftLeft(intIsWin8 And 2,2)
- i = 24
- strChars = "BCDFGHJKMPQRTVWXY2346789"
- strKeyOutput = ""
- While i > -1
- intCur = 0
- intX = 14
- While intX > -1
- intCur = BitShiftLeft(intCur,8)
- intCur = arrKey(intX + intKeyOffset) + intCur
- arrKey(intX + intKeyOffset) = Int(intCur / 24)
- intCur = intCur Mod 24
- intX = intX - 1
- Wend
- i = i - 1
- strKeyOutput = Mid(strChars,intCur + 1,1) & strKeyOutput
- intLast = intCur
- Wend
- If intIsWin8 = 1 Then
- strKeyOutput = Mid(strKeyOutput,2,intLast) & "N" & Right(strKeyOutput,Len(strKeyOutput) - (intLast + 1))
- End If
- strKeyGUIDOutput = Mid(strKeyOutput,1,5) & "-" & Mid(strKeyOutput,6,5) & "-" & Mid(strKeyOutput,11,5) & "-" & Mid(strKeyOutput,16,5) & "-" & Mid(strKeyOutput,21,5)
- DecodeProductKey = strKeyGUIDOutput
- End Function
- Function RegReadBinary(strRegPath,strRegValue)
- Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
- objReg.GetBinaryValue HKLM,strRegPath,strRegValue,arrRegBinaryData
- RegReadBinary = arrRegBinaryData
- Set objReg = Nothing
- End Function
- Function BitShiftLeft(intValue,intShift)
- BitShiftLeft = intValue * 2 ^ intShift
- End Function
- Function BitShiftRight(intValue,intShift)
- BitShiftRight = Int(intValue / (2 ^ intShift))
- End Function
- Function QueryOfficeProductKeys()
- strBaseKey = "SOFTWARE\"
- strOfficeKey = strBaseKey & "Microsoft\Office"
- Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
- objReg.EnumKey HKLM, strOfficeKey, arrOfficeVersionSubKeys
- intProductCount = 1
- If IsArray(arrOfficeVersionSubKeys) Then
- For Each strOfficeVersionKey In arrOfficeVersionSubKeys
- Select Case strOfficeVersionKey
- Case "11.0"
- CheckOfficeKey strOfficeKey & "\11.0\Registration",52,intProductCount
- Case "12.0"
- CheckOfficeKey strOfficeKey & "\12.0\Registration",52,intProductCount
- Case "14.0"
- CheckOfficeKey strOfficeKey & "\14.0\Registration",808,intProductCount
- Case "15.0"
- CheckOfficeKey strOfficeKey & "\15.0\Registration",808,intProductCount
- End Select
- Next
- End If
- strBaseKey = "SOFTWARE\Wow6432Node\"
- strOfficeKey = strBaseKey & "Microsoft\Office"
- Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
- objReg.EnumKey HKLM, strOfficeKey, arrOfficeVersionSubKeys
- intProductCount = 1
- If IsArray(arrOfficeVersionSubKeys) Then
- For Each strOfficeVersionKey In arrOfficeVersionSubKeys
- Select Case strOfficeVersionKey
- Case "11.0"
- CheckOfficeKey strOfficeKey & "\11.0\Registration",52,intProductCount
- Case "12.0"
- CheckOfficeKey strOfficeKey & "\12.0\Registration",52,intProductCount
- Case "14.0"
- CheckOfficeKey strOfficeKey & "\14.0\Registration",808,intProductCount
- Case "15.0"
- CheckOfficeKey strOfficeKey & "\15.0\Registration",808,intProductCount
- End Select
- Next
- End If
- End Function
- 'Office Product Key
- Sub CheckOfficeKey(strRegPath,intKeyOffset,intProductCount)
- Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
- objReg.EnumKey HKLM, strRegPath, arrOfficeRegistrations
- If IsArray(arrOfficeRegistrations) Then
- For Each strOfficeRegistration In arrOfficeRegistrations
- objReg.GetStringValue HKLM,strRegPath & "\" & strOfficeRegistration,"ConvertToEdition",strOfficeEdition
- objReg.GetBinaryValue HKLM,strRegPath & "\" & strOfficeRegistration,"DigitalProductID",arrProductID
- If strOfficeEdition <> "" And IsArray(arrProductID) Then
- WriteData "Product", strOfficeEdition
- WriteData "Key", DecodeProductKey(arrProductID,intKeyOffset) & vbCrLf
- intProductCount = intProductCount + 1
- End If
- Next
- End If
- End Sub
- 'Windows Product Key
- Sub QueryWindowsProductKeys()
- strWinKey = CheckWindowsKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion","DigitalProductId",52)
- If strWinKey <> "" Then
- WriteData "Product: " & Caption & Version & " (" & OSArchitecture & ")", ""
- 'WriteData "Installation Date: " & NewDate
- WriteData "Key", strWinKey & vbnewline
- Exit Sub
- End If
- strWinKey = CheckWindowsKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion","DigitalProductId4",808)
- If strWinKey <> "" Then
- WriteData "Product: " & Caption & Version & " (" & OSArchitecture & ")", ""
- 'WriteData "Installation Date: " & NewDate
- WriteData "Key", strWinKey & vbnewline
- Exit Sub
- End If
- strWinKey = CheckWindowsKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion\DefaultProductKey","DigitalProductId",52)
- If strWinKey <> "" Then
- WriteData "Product: " & Caption & Version & " (" & OSArchitecture & ")", ""
- 'WriteData"Installation Date: " & NewDate
- WriteData "Key", strWinKey & vbnewline
- Exit Sub
- End If
- strWinKey = CheckWindowsKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion\DefaultProductKey","DigitalProductId4",808)
- If strWinKey <> "" Then
- WriteData "Product: " & Caption & Version & " (" & OSArchitecture & ")", ""
- 'WriteData "Installation Date: " & NewDate
- WriteData "Key", strWinKey & vbnewline
- Exit Sub
- End If
- End Sub
- Function CheckWindowsKey(strRegPath,strRegValue,intKeyOffset)
- strWinKey = DecodeProductKey(RegReadBinary(strRegPath,strRegValue),intKeyOffset)
- If strWinKey <> "BBBBB-BBBBB-BBBBB-BBBBB-BBBBB" And strWinKey <> "" Then
- CheckWindowsKey = strWinKey
- Else
- CheckWindowsKey = ""
- End If
- End Function
- Function RegReadBinary(strRegPath,strRegValue)
- Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
- objReg.GetBinaryValue HKLM,strRegPath,strRegValue,arrRegBinaryData
- RegReadBinary = arrRegBinaryData
- Set objReg = Nothing
- End Function
- Function OsArch()
- Set objShell = WScript.CreateObject("WScript.Shell")
- If objShell.ExpandEnvironmentStrings("%ProgramFiles(x86)%") = "%ProgramFiles(x86)%" Then
- OsArch = "x86"
- Else
- OsArch = "x64"
- End If
- Set objShell = Nothing
- End Function
- Sub WriteData(strProperty,strValue)
- objFileToWrite.WriteLine strProperty & ": " & Trim(strValue)
- 'Set objShell = CreateObject("WScript.Shell")
- 'strKey = "HKLM\SOFTWARE\CentraStage\Custom\" & strProperty
- 'objShell.RegWrite strKey,Trim(strValue),"REG_SZ"
- 'Set objShell = Nothing
- End Sub
- wscript.echo "Successfully Saved"
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement