Hi Guys!
Parabellum, I have to say, Very well done with your script. It's exactly what i've been looking for! Legend!
But I have a slight hiccup... I have integrated your script with one from
microsofts TechNet website and now I am getting a Syntax Error on Line 102 Character 1
That line is: Function decodeKey(iValues, strProduct)
I am pretty good at vbs, but this one threw me in for quite a loop..... I don't know how to fix it.
It honestly makes no sence at all because essentially all I am doing is pinging each computer and if it replys it runs the keycheck script against that machine then dumps it to a file,
then moves on to the next one. Why Syntax Error? It a Function!
Can you make heads or tails of this?
Thanks to Any/Everyone in advance!
On Error Resume Next
Const WbemAuthenticationLevelPktPrivacy = 6
strCredentials = InputBox _
("Please enter the user name, a blank space, and then the password:", _
"Enter User Credentials")
If strCredentials = "" Then
Wscript.Echo "Username and password must be provided. Now quitting."
Wscript.Quit
End If
arrCredentials = Split(strCredentials," ")
strUser = arrCredentials(0)
strPassword = arrCredentials(1)
strSubnetInput = InputBox("Enter the SubNet of the network you wish to scan." & VbCrLf &_
VbCrLf & " Example: 192.168.xx.1")
intStartingAddressInput = InputBox("Enter the starting address of the ping scan." & VbCrLf &_
VbCrLf & "Example: 192.168." & strSubnetInput & ".1-254")
intEndingAddressInput = InputBox("Enter the ending address of the Ping scan" & VbCrLf &_
VbCrLf & "Example: 192.168." & strSubnetInput & "." & intStartingAddressInput & "-255")
strSubnet = "192.168."& strSubnetInput &"."
For i = intStartingAddressInput to intEndingAddressInput
strComputer = strSubnet & i
Set objShell = CreateObject("WScript.Shell")
strCommand = "%comspec% /c ping -n 1 -w 200 " & strComputer & ""
Set objExecObject = objShell.Exec(strCommand)
Do While Not objExecObject.StdOut.AtEndOfStream
strText = objExecObject.StdOut.ReadAll()
If Instr(strText, "Reply") > 0 Then
Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
Set objWMIService = objwbemLocator.ConnectServer _
(strComputer, strNamespace, strUser, strPassword)
objWMIService.Security_.authenticationLevel = WbemAuthenticationLevelPktPrivacy
Set objFileSys = CreateObject ("Scripting.FileSystemObject")
logfile = "PingPong." & strSubnetInput & ".txt"
Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
filetemp.Write strComputer & " Ping... Pong"
filetemp.Write VbCrLf
filetemp.Close
'===============================================================
' ##############################################################
' # #
' # VBScript to retrieve Microsoft Product Keys #
' # from the registry by decoding DigitalProductID's #
' # #
' # -------------------------------------------------- #
' # Created by: Parabellum #
' # #
' ##############################################################
'
CONST HKEY_LOCAL_MACHINE = &H80000002
CONST SEARCH_KEY = "DigitalProductID"
Dim arrSubKeys(4,1)
Dim foundKeys
Dim iValues, arrDPID
foundKeys = Array()
iValues = Array()
arrSubKeys(0,0) = "Microsoft Windows Product Key"
arrSubKeys(0,1) = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
arrSubKeys(2,0) = "Microsoft Office XP"
arrSubKeys(2,1) = "SOFTWARE\Microsoft\Office\10.0\Registration"
arrSubKeys(1,0) = "Microsoft Office 2003"
arrSubKeys(1,1) = "SOFTWARE\Microsoft\Office\11.0\Registration"
arrSubKeys(3,0) = "Microsoft Office 2007"
arrSubKeys(3,1) = "SOFTWARE\Microsoft\Office\12.0\Registration"
arrSubKeys(4,0) = "Microsoft Exchange Product Key"
arrSubKeys(4,1) = "SOFTWARE\Microsoft\Exchange\Setup"
' <--------------- Open Registry Key and populate binary data into an array -------------------------->
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
call decodeKey(arrDPIDBytes, arrSubKeys(x,0))
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
call decodeKey(arrDPIDBytes, arrSubKeys(x,0))
End If
Next
End If
End If
Next
MsgBox("Finished")
' <----------------------------------------- Return the Product Key --------------------------------------------------->
Function decodeKey(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 Product Key -------------------------->
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)
Set objFileSys = CreateObject ("Scripting.FileSystemObject")
logfile = "PC-Info.txt"
Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
filetemp.Write strComputer
filetemp.Write strProduct & vbNewLine & foundKeys(strKey) & vbNewLine
filetemp.Write VbCrLf
filetemp.Close
End Function
' =====================================================================
Else
Set objFileSys = CreateObject ("Scripting.FileSystemObject")
logfile = "PingPong." & strSubnetInput & ".txt"
Set filetemp = objFileSys.OpenTextFile(logfile, 8, True)
filetemp.Write strComputer & " Ping..."
filetemp.Write VbCrLf
filetemp.Close
End If
Loop
Next
<message edited by hickory420 on Tuesday, September 02, 2008 5:01 PM>