Hi,
This is a great script, I am ENTIRELY new to VB so I am lost...I got it running pulled my windows product id from the domain and all is good that way.
I have a couple questions though:
1. I can't get it to work so I can pull the office, visio, or other MS product id's? Anyone able to help? I am using the script below:
2. I also want to see if this can go to a csv file or excel?
' ##########################################
' # #
' # VBScript to Retrieve a List of Computers from Active #
' # Directory, check connectivity and generate a report file #
' # containing Microsoft Windows Licensing Information. #
' # #
' ##########################################
'
Dim objDomain, strComputer, strADComputer, PC, strKeyPath, strValueName, oReg
Dim ADCompList, ActiveCompList, RetrievedKeys
Dim IE, oFSO, objShell, strPath, objFile
Set IE = CreateObject("InternetExplorer.Application")
Set objShell = CreateObject("Wscript.Shell")
strPath = Wscript.ScriptFullName
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(strPath)
strPath = objFSO.GetParentFolderName(objFile)
With IE
.left=200
.top=200
.height=140
.width=250
.menubar=0
.toolbar=0
.statusBar=0
.navigate "About:Blank"
.visible=1
End With
'wait a while until IE as finished to load
Do while IE.busy
loop
With IE.document
.Open
.WriteLn "<html>"
.WriteLn "<head>"
.WriteLn "<HTA:APPLICATION "
.WriteLn " ID='objNoTitleBar'"
.WriteLn " CAPTION=no"
.WriteLn " SHOWINTASKBAR='NO'"
.WriteLn " BORDER='NONE'"
.WriteLn " APPLICATIONNAME='Please Wait'"
.WriteLn " SCROLL='AUTO'"
.WriteLn " SINGLEINSTANCE='yes'"
.WriteLn ">"
.WriteLn "</head>"
.WriteLn "<body text='#ffffff' bgcolor='#000000'>"
.WriteLn "<center>Please Wait....<br /><br />"
.WriteLn "<img src='" & strPath & "\ajax-loader.gif' /></center>"
.WriteLn "</body>"
.WriteLn "</html>"
.Close
End With
ADCompList = Array(0)
' Connect to root of domain
Dim rootDSE, domainContainer
Set rootDSE = GetObject("LDAP://RootDSE")
domainContainer = rootDSE.Get("defaultNamingContext")
Set ObjDomain = GetObject("LDAP://" & domainContainer)
' Enumerate through the domain
WorkWithObject(ObjDomain)
Sub WorkWithObject(oContainer)
Dim oADObject
For Each oADObject in oContainer
Select Case oADObject.Class
Case "computer"
Dim strADComputer
strADComputer = oADObject.cn
ADCompList(UBound(ADCompList)) = strADComputer
ReDim Preserve ADCompList(UBound(ADCompList) + 1)
Case "organizationalUnit" , "container"
WorkWithObject(oADObject)
End Select
Next
End Sub
ReDim Preserve ADCompList(UBound(ADCompList) - 1)
ActiveCompList = Array(0)
For Each PC In ADCompList
If Reachable(PC) Then
ActiveCompList(UBound(ActiveCompList)) = PC
ReDim Preserve ActiveCompList(UBound(ActiveCompList) + 1)
End If
Next
ReDim Preserve ActiveCompList(UBound(ActiveCompList) - 1)
Set objXMLDoc = CreateObject("Microsoft.XMLDOM")
Set rootEl = objXMLDoc.createElement("Computers")
objXMLDoc.appendChild rootEl
Dim objCurrNode, objNewNode, objNewText
' <--------------- Open Registry Key and populate binary data into an array -------------------------->
const HKEY_LOCAL_MACHINE = &H80000002
strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion"
strValueName = "DigitalProductId"
Dim iValues()
On Error Resume Next
For Each strComputer In ActiveCompList
Set objPCField = objXMLDoc.createElement("PC")
rootEl.appendChild(objPCField)
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
oReg.GetBinaryValue HKEY_LOCAL_MACHINE,strKeyPath,strValueName,iValues
Dim arrDPID
arrDPID = Array()
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 !!! (Decrypt the base24 encoded binary data)-------------------------->
strProductKey = ""
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
strFinalKey = strProductKey
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery("select * from Win32_OperatingSystem")
For Each objOperatingsystem in colOperatingSystems
strOS = objOperatingsystem.Caption
strBuild = objOperatingsystem.BuildNumber
strSerial = objOperatingsystem.SerialNumber
strRegistered = objOperatingsystem.RegisteredUser
Next
Set objNewNode = objXMLDoc.createElement("Name")
Set objNewText = objXMLDoc.createTextNode(strComputer)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("OS")
Set objNewText = objXMLDoc.createTextNode(strOS)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("Build")
Set objNewText = objXMLDoc.createTextNode(strBuild)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("PID")
Set objNewText = objXMLDoc.createTextNode(strSerial)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("RegisteredTo")
Set objNewText = objXMLDoc.createTextNode(strRegistered)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Set objNewNode = objXMLDoc.createElement("Key")
Set objNewText = objXMLDoc.createTextNode(strFinalKey)
objPCField.appendChild(objNewNode)
objNewNode.appendChild(objNewText)
Next
'Add an XML processing instruction and insert it before the root element
Set p=objXMLDoc.createProcessingInstruction("xml","version='1.0'")
xmlDoc.insertBefore p,objXMLDoc.childNodes(0)
objXMLDoc.Save("report.xml")
IE.Quit
set IE = Nothing
MsgBox("Finished")
' <----------------------- Function to check if computer is switched on and responding to Ping ---------------------->
Function Reachable(strComputer)
' On Error Resume Next
Dim wmiQuery, objWMIService, objPing, objStatus
wmiQuery = "Select * From Win32_PingStatus Where Address = '" & strComputer & "'"
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objPing = objWMIService.ExecQuery(wmiQuery)
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) Or objStatus.Statuscode<>0 Then
Reachable = False 'if computer is unreacable, return false
Else
Reachable = True 'if computer is reachable, return true
End If
Next
End Function