Script that queries the registry for all the applications that are installed on a domain member pc &..
Hi,
I need a script that when ran outputs the date and time,Machine name, version of the OS and service pack, who is the local administrator( this one is not that important ) and queries the registry for all the applications that are currently installed.
Rob The Genius do me proud.
Thank you all
Sean
I need a script that when ran outputs the date and time,Machine name, version of the OS and service pack, who is the local administrator( this one is not that important ) and queries the registry for all the applications that are currently installed.
Rob The Genius do me proud.
Thank you all
Sean
Guys, there's no need to reinvent the wheel - sysinternals have a gadget for this!
PSTools:
http://technet.microsoft.com/en-us/sysinternals/bb897550.aspx
On the command line, indicate the computer (or use * for all computers it can see), and the -s switch lists installed applications. :)
Happy playing :)
PSTools:
http://technet.microsoft.com/en-us/sysinternals/bb897550.aspx
On the command line, indicate the computer (or use * for all computers it can see), and the -s switch lists installed applications. :)
Happy playing :)
greymirror, which component of PSTools does this for us?
Anyway guys, here's a VBS I have written that gets computers names from a text file called "computers.txt" and output their installed apps to Excel:
'===================
'*************************
' This function uses the following Reg Key:
' SOFTWARE\Microsoft\Windows
' to return the list of programs that are listed in the Add / Remove
' Programs applet of the control panel.
'
' GetOfficeDetails.vbs uses a WQL query of "SELECT * FROM Win32_Product"
' to obtain the list of software products that have been installed
' using the Microsoft Windows Installer.
'*************************
Option Explicit
Dim strWorkingDir
Dim strAllPCsFile, objAllPCsFile, strSearchResultsFile, strOutputFile
Dim strSinglePC, strComputer, arrSinglePC, strKey, strSubKey, strUserName
Dim objRegistry
Dim arrSubKeys()
Dim strDisplayName, strDisplayVersion, strInstallLocation
Dim strScriptName, strScriptPath, strFileOutputPath
Dim strAllDetails, objFSO, objExec, strActivePCs, arrActivePCs, strInactivePCs
Dim arrResultsRows, arrResultsTable, intRowNum, intColNum
Dim objWMIService, colAllSoftware, objSoftware, colComputer, objComputer
Dim boolShowMSKBPatches
Dim boolPinged
Dim arrComputerPrograms 'Global variable to hold the computer programs per computer
Const HKEY_LOCAL_MACHINE = &H80000002
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
strWorkingDir = Replace(WScript.ScriptFull
'MsgBox strWorkingDir
If Left(strWorkingDir, 2) = "\\" Then
MsgBox "Please run this program from a network drive.", vbOKOnly, "Error"
WScript.Quit
End If
boolShowMSKBPatches = MsgBox("Do you want to display Micorosoft KnowledgeBase Patches?", vbYesNo, "Display Patches?")
If boolShowMSKBPatches = vbYes Then
boolShowMSKBPatches = True
Else
boolShowMSKBPatches = False
End If
'MsgBox boolShowMSKBPatches
strAllPCsFile = "Computers.txt"
strSearchResultsFile = "Results.txt"
strOutputFile = "InactivePCs.txt"
strInactivePCs = ""
strAllDetails = ""
Set objFSO = CreateObject("Scripting.Fi
Set objAllPCsFile = objFSO.OpenTextFile(strAll
While Not objAllPCsFile.AtEndOfStrea
strComputer = objAllPCsFile.ReadLine
'MsgBox "About to ping: " & strComputer
boolPinged = Ping(strComputer)
If boolPinged = True Then
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputer = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strUserName = "User Name: " & objComputer.UserName
Next
'WScript.Echo strComputer & " responded to ping."
' **************************
' ********** START OF FIRST METHOD - Add / Remove Programs ************
' **************************
strKey = "SOFTWARE\Microsoft\Window
'MsgBox "Ping successful on: " & strComputer
On Error Resume Next
Set objRegistry = GetObject("winmgmts:" & _
"{impersonationLevel=Imper
strComputer & "\root\default:StdRegProv"
If Err.Number <> 0 Then
MsgBox "There was a problem connecting to: " & strComputer & "."
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
Err.Clear
On Error GoTo 0
Else
objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubKeys
On Error Resume Next
For Each strSubKey In arrSubKeys
objRegistry.GetStringValue
objRegistry.GetStringValue
objRegistry.GetStringValue
'strAllDetails = strAllDetails & strComputer & ";" & strSubKey & ";" & strDisplayName & ";" & strDisplayVersion & VbCrLf
If strDisplayName <> "" Then
If boolShowMSKBPatches = False Then
If InStr(strDisplayName, " KB") = 0 And InStr(strDisplayName, "(KB") = 0 Then
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
Else
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
End If
strDisplayName = vbEmpty
strDisplayVersion = vbEmpty
strInstallLocation = vbEmpty
Next
On Error GoTo 0
' **************************
' *********** END OF FIRST METHOD - Add / Remove Programs ***************
' **************************
' *********** START OF SECOND METHOD - Windows Installer ****************
' **************************
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=imper
' & strComputer & "\root\cimv2")
Set colAllSoftware = objWMIService.ExecQuery _
("Select * from Win32_Product")
On Error Resume Next
For Each objSoftware in colAllSoftware
'strAllSoftware = strAllSoftware & "Name: " & objSoftware.Name & vbcrlf & "Version: " & objSoftware.Version & vbcrlf
If strAllDetails = "" Then
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
Else
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
End If
Next
On Error GoTo 0
' **************************
' *********** END OF SECOND METHOD - Windows Installer *****************
' **************************
strActivePCs = strActivePCs & strComputer & ";"
End If
Else
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
End If
Wend
If Right(strActivePCs, 1) = ";" Then
strActivePCs = Left(strActivePCs, Len(strActivePCs) - 1)
End If
arrActivePCs = Split(strActivePCs, ";")
' ********** Create the main Results Table array ************
If strAllDetails = "" Then
MsgBox "There are no results to display. Please check that any PCs are active."
WScript.Quit
End If
arrResultsRows = Split(strAllDetails, VbCrLf)
'MsgBox arrResultsRows(UBound(arrR
'MsgBox Split(arrResultsRows(UBoun
ReDim arrResultsTable(UBound(arr
'MsgBox "STRING:" & Right(strAllDetails, 100) & ":STRING"
For intRowNum = LBound(arrResultsRows) To UBound(arrResultsRows)
For intColNum = LBound(Split(arrResultsRow
'MsgBox intRowNum & ":" & intColNum
'If IsDate(Split(arrResultsRow
arrResultsTable(intRowNum,
'Else
' arrResultsTable(intRowNum,
'End If
Next
Next
' ********** End of creating the main Results Table array **************
Output_To_Excel
Dim objFS
Dim objOutputFile
Set objFS = CreateObject("Scripting.Fi
Set objOutputFile = objFS.CreateTextFile(strOu
objOutputFile.Write(strIna
objOutputFile.Close
MsgBox "InactivePCs have been recorded." & vbcrlf & "Please see " & strOutputFile & ".", vbOKOnly, "Output Finished"
'*************************
Sub Output_To_Excel
Dim objExcel, objExcelWorkBook, intSheetCount
Dim strAllPrinters, intActivePCCounter
Dim intRowCounter, intColCounter
Dim intProgramCounter, intComputerProgramCount
If IsArray(arrResultsTable) = True Then
Set objExcel = CreateObject("EXCEL.APPLIC
objExcel.Visible = True
objExcel.WorkBooks.Add
Set objExcelWorkBook = objExcel.ActiveWorkbook
objExcelWorkBook.Activate
objExcel.DisplayAlerts = False
Do While objExcel.Sheets.Count > 1
objExcel.Sheets(1).Delete
Loop
objExcel.DisplayAlerts = True
' *************** All Printers ***************
' objExcel.Sheets(1).Name = "All Printers"
' Display_All_Printers "Excel", objExcel
' **************************
' *********** Individual Printers ************
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
objExcel.Sheets(1).Select
objExcel.Sheets.Add
objExcel.Sheets(1).Name = arrActivePCs(intActivePCCo
objExcel.Sheets(arrActiveP
objExcel.Sheets(arrActiveP
Next
objExcel.Sheets(1).Delete
objExcel.ScreenUpdating = False
Show_Computer_Programs objExcel
' **************************
objExcel.Sheets(1).Select
objExcel.ActiveSheet.Range
objExcel.ScreenUpdating = True
MsgBox "There were " & objExcel.Sheets.Count & " PCs inspected."
Set objExcelWorkBook = Nothing
Set objExcel = Nothing
Else
MsgBox "No programs have been retrieved. Cannot output to Excel."
End If
End Sub
'*************************
Sub Write_Excel_Header_Row(obj
Dim arrFields
Dim intColCounter, strLastColumn
arrFields = Array("Computer", "Owner", "Software", "Version")
For intColCounter = LBound(arrFields) To UBound(arrFields)
objExcelApp.ActiveSheet.Ra
Next
strLastColumn = Chr(UBound(arrFields) + 65)
objExcelApp.ActiveSheet.Ra
objExcelApp.ActiveSheet.Ra
objExcelApp.Cells.Select
objExcelApp.Selection.Sort
objExcelApp.ActiveSheet.Ra
End Sub
'*************************
Sub Show_Computer_Programs(obj
Dim intProgramCounter, intComputerProgramCount, intRowCounter, intColCounter, intActivePCCounter
If IsArray(arrResultsTable) = True Then
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
intComputerProgramCount = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
'MsgBox "Table: " & arrResultsTable(intProgram
If arrResultsTable(intProgram
intComputerProgramCount = intComputerProgramCount + 1
End If
Next
ReDim arrComputerPrograms(intCom
intRowCounter = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
If arrResultsTable(intProgram
For intColCounter = LBound(Split(arrResultsRow
arrComputerPrograms(intRow
Next
intRowCounter = intRowCounter + 1
End If
Next
If UBound(arrComputerPrograms
objExcelObj.Sheets(arrActi
Display_Single_Computer_Pr
Else
objExcelObj.Sheets(arrActi
Write_Excel_Header_Row objExcelObj
End If
Next
Else
MsgBox "No programs have been retrieved."
End If
End Sub
'*************************
Sub Display_Single_Computer_Pr
Dim intRowCounter, intColCounter
objExcelObj.ActiveSheet.Ce
objExcelObj.Selection.Numb
For intRowCounter = LBound(arrComputerPrograms
For intColCounter = LBound(Split(arrResultsRow
objExcelObj.ActiveSheet.Ra
If InStr(arrComputerPrograms(
objExcelObj.ActiveSheet.Ra
objExcelObj.Selection.Font
objExcelObj.Selection.Font
End If
Next
Next
Write_Excel_Header_Row(obj
End Sub
'************* PING FUNCTION ********************
Function Ping(ByVal strName)
Dim objFSO, objShell, objTempFile, objTS, strTempFile
Dim strCommand, strReadLine
Dim boolReturn
Set objShell = WScript.CreateObject("Wscr
Set objFSO = CreateObject("Scripting.Fi
strTempFile = strWorkingDir & "temp.txt"
'Set default return value
boolReturn = False
'Create command line to ping and save results to a temp file
strCommand = "cmd /c ping.exe -n 1 -w 500 " & strName & " > """ & strTempFile & """"
'Execute the command
objShell.Run strCommand, 0, True
'Open the temp text file
Set objTempFile = objFSO.GetFile(strTempFile
Set objTS = objTempFile.OpenAsTextStre
'Loop through the temp file to see if "reply from" is found,
'if it is then the ping was successful
Do While objTs.AtEndOfStream <> True
strReadLine = objTs.ReadLine
If InStr(LCase(strReadLine), "reply from") > 0 Then
boolReturn = True
Exit Do
End If
Loop
'Close temp file and release objects
objTS.Close
objTempFile.Delete True
Set objTS = Nothing
Set objTempFile = Nothing
Set objShell = Nothing
Set objFSO = Nothing
'Return value
Ping = boolReturn
End Function
'===================
Regards,
Rob.
Anyway guys, here's a VBS I have written that gets computers names from a text file called "computers.txt" and output their installed apps to Excel:
'===================
'*************************
' This function uses the following Reg Key:
' SOFTWARE\Microsoft\Windows
' to return the list of programs that are listed in the Add / Remove
' Programs applet of the control panel.
'
' GetOfficeDetails.vbs uses a WQL query of "SELECT * FROM Win32_Product"
' to obtain the list of software products that have been installed
' using the Microsoft Windows Installer.
'*************************
Option Explicit
Dim strWorkingDir
Dim strAllPCsFile, objAllPCsFile, strSearchResultsFile, strOutputFile
Dim strSinglePC, strComputer, arrSinglePC, strKey, strSubKey, strUserName
Dim objRegistry
Dim arrSubKeys()
Dim strDisplayName, strDisplayVersion, strInstallLocation
Dim strScriptName, strScriptPath, strFileOutputPath
Dim strAllDetails, objFSO, objExec, strActivePCs, arrActivePCs, strInactivePCs
Dim arrResultsRows, arrResultsTable, intRowNum, intColNum
Dim objWMIService, colAllSoftware, objSoftware, colComputer, objComputer
Dim boolShowMSKBPatches
Dim boolPinged
Dim arrComputerPrograms 'Global variable to hold the computer programs per computer
Const HKEY_LOCAL_MACHINE = &H80000002
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
strWorkingDir = Replace(WScript.ScriptFull
'MsgBox strWorkingDir
If Left(strWorkingDir, 2) = "\\" Then
MsgBox "Please run this program from a network drive.", vbOKOnly, "Error"
WScript.Quit
End If
boolShowMSKBPatches = MsgBox("Do you want to display Micorosoft KnowledgeBase Patches?", vbYesNo, "Display Patches?")
If boolShowMSKBPatches = vbYes Then
boolShowMSKBPatches = True
Else
boolShowMSKBPatches = False
End If
'MsgBox boolShowMSKBPatches
strAllPCsFile = "Computers.txt"
strSearchResultsFile = "Results.txt"
strOutputFile = "InactivePCs.txt"
strInactivePCs = ""
strAllDetails = ""
Set objFSO = CreateObject("Scripting.Fi
Set objAllPCsFile = objFSO.OpenTextFile(strAll
While Not objAllPCsFile.AtEndOfStrea
strComputer = objAllPCsFile.ReadLine
'MsgBox "About to ping: " & strComputer
boolPinged = Ping(strComputer)
If boolPinged = True Then
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputer = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strUserName = "User Name: " & objComputer.UserName
Next
'WScript.Echo strComputer & " responded to ping."
' **************************
' ********** START OF FIRST METHOD - Add / Remove Programs ************
' **************************
strKey = "SOFTWARE\Microsoft\Window
'MsgBox "Ping successful on: " & strComputer
On Error Resume Next
Set objRegistry = GetObject("winmgmts:" & _
"{impersonationLevel=Imper
strComputer & "\root\default:StdRegProv"
If Err.Number <> 0 Then
MsgBox "There was a problem connecting to: " & strComputer & "."
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
Err.Clear
On Error GoTo 0
Else
objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubKeys
On Error Resume Next
For Each strSubKey In arrSubKeys
objRegistry.GetStringValue
objRegistry.GetStringValue
objRegistry.GetStringValue
'strAllDetails = strAllDetails & strComputer & ";" & strSubKey & ";" & strDisplayName & ";" & strDisplayVersion & VbCrLf
If strDisplayName <> "" Then
If boolShowMSKBPatches = False Then
If InStr(strDisplayName, " KB") = 0 And InStr(strDisplayName, "(KB") = 0 Then
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
Else
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
End If
strDisplayName = vbEmpty
strDisplayVersion = vbEmpty
strInstallLocation = vbEmpty
Next
On Error GoTo 0
' **************************
' *********** END OF FIRST METHOD - Add / Remove Programs ***************
' **************************
' *********** START OF SECOND METHOD - Windows Installer ****************
' **************************
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=imper
' & strComputer & "\root\cimv2")
Set colAllSoftware = objWMIService.ExecQuery _
("Select * from Win32_Product")
On Error Resume Next
For Each objSoftware in colAllSoftware
'strAllSoftware = strAllSoftware & "Name: " & objSoftware.Name & vbcrlf & "Version: " & objSoftware.Version & vbcrlf
If strAllDetails = "" Then
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
Else
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
End If
Next
On Error GoTo 0
' **************************
' *********** END OF SECOND METHOD - Windows Installer *****************
' **************************
strActivePCs = strActivePCs & strComputer & ";"
End If
Else
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
End If
Wend
If Right(strActivePCs, 1) = ";" Then
strActivePCs = Left(strActivePCs, Len(strActivePCs) - 1)
End If
arrActivePCs = Split(strActivePCs, ";")
' ********** Create the main Results Table array ************
If strAllDetails = "" Then
MsgBox "There are no results to display. Please check that any PCs are active."
WScript.Quit
End If
arrResultsRows = Split(strAllDetails, VbCrLf)
'MsgBox arrResultsRows(UBound(arrR
'MsgBox Split(arrResultsRows(UBoun
ReDim arrResultsTable(UBound(arr
'MsgBox "STRING:" & Right(strAllDetails, 100) & ":STRING"
For intRowNum = LBound(arrResultsRows) To UBound(arrResultsRows)
For intColNum = LBound(Split(arrResultsRow
'MsgBox intRowNum & ":" & intColNum
'If IsDate(Split(arrResultsRow
arrResultsTable(intRowNum,
'Else
' arrResultsTable(intRowNum,
'End If
Next
Next
' ********** End of creating the main Results Table array **************
Output_To_Excel
Dim objFS
Dim objOutputFile
Set objFS = CreateObject("Scripting.Fi
Set objOutputFile = objFS.CreateTextFile(strOu
objOutputFile.Write(strIna
objOutputFile.Close
MsgBox "InactivePCs have been recorded." & vbcrlf & "Please see " & strOutputFile & ".", vbOKOnly, "Output Finished"
'*************************
Sub Output_To_Excel
Dim objExcel, objExcelWorkBook, intSheetCount
Dim strAllPrinters, intActivePCCounter
Dim intRowCounter, intColCounter
Dim intProgramCounter, intComputerProgramCount
If IsArray(arrResultsTable) = True Then
Set objExcel = CreateObject("EXCEL.APPLIC
objExcel.Visible = True
objExcel.WorkBooks.Add
Set objExcelWorkBook = objExcel.ActiveWorkbook
objExcelWorkBook.Activate
objExcel.DisplayAlerts = False
Do While objExcel.Sheets.Count > 1
objExcel.Sheets(1).Delete
Loop
objExcel.DisplayAlerts = True
' *************** All Printers ***************
' objExcel.Sheets(1).Name = "All Printers"
' Display_All_Printers "Excel", objExcel
' **************************
' *********** Individual Printers ************
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
objExcel.Sheets(1).Select
objExcel.Sheets.Add
objExcel.Sheets(1).Name = arrActivePCs(intActivePCCo
objExcel.Sheets(arrActiveP
objExcel.Sheets(arrActiveP
Next
objExcel.Sheets(1).Delete
objExcel.ScreenUpdating = False
Show_Computer_Programs objExcel
' **************************
objExcel.Sheets(1).Select
objExcel.ActiveSheet.Range
objExcel.ScreenUpdating = True
MsgBox "There were " & objExcel.Sheets.Count & " PCs inspected."
Set objExcelWorkBook = Nothing
Set objExcel = Nothing
Else
MsgBox "No programs have been retrieved. Cannot output to Excel."
End If
End Sub
'*************************
Sub Write_Excel_Header_Row(obj
Dim arrFields
Dim intColCounter, strLastColumn
arrFields = Array("Computer", "Owner", "Software", "Version")
For intColCounter = LBound(arrFields) To UBound(arrFields)
objExcelApp.ActiveSheet.Ra
Next
strLastColumn = Chr(UBound(arrFields) + 65)
objExcelApp.ActiveSheet.Ra
objExcelApp.ActiveSheet.Ra
objExcelApp.Cells.Select
objExcelApp.Selection.Sort
objExcelApp.ActiveSheet.Ra
End Sub
'*************************
Sub Show_Computer_Programs(obj
Dim intProgramCounter, intComputerProgramCount, intRowCounter, intColCounter, intActivePCCounter
If IsArray(arrResultsTable) = True Then
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
intComputerProgramCount = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
'MsgBox "Table: " & arrResultsTable(intProgram
If arrResultsTable(intProgram
intComputerProgramCount = intComputerProgramCount + 1
End If
Next
ReDim arrComputerPrograms(intCom
intRowCounter = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
If arrResultsTable(intProgram
For intColCounter = LBound(Split(arrResultsRow
arrComputerPrograms(intRow
Next
intRowCounter = intRowCounter + 1
End If
Next
If UBound(arrComputerPrograms
objExcelObj.Sheets(arrActi
Display_Single_Computer_Pr
Else
objExcelObj.Sheets(arrActi
Write_Excel_Header_Row objExcelObj
End If
Next
Else
MsgBox "No programs have been retrieved."
End If
End Sub
'*************************
Sub Display_Single_Computer_Pr
Dim intRowCounter, intColCounter
objExcelObj.ActiveSheet.Ce
objExcelObj.Selection.Numb
For intRowCounter = LBound(arrComputerPrograms
For intColCounter = LBound(Split(arrResultsRow
objExcelObj.ActiveSheet.Ra
If InStr(arrComputerPrograms(
objExcelObj.ActiveSheet.Ra
objExcelObj.Selection.Font
objExcelObj.Selection.Font
End If
Next
Next
Write_Excel_Header_Row(obj
End Sub
'************* PING FUNCTION ********************
Function Ping(ByVal strName)
Dim objFSO, objShell, objTempFile, objTS, strTempFile
Dim strCommand, strReadLine
Dim boolReturn
Set objShell = WScript.CreateObject("Wscr
Set objFSO = CreateObject("Scripting.Fi
strTempFile = strWorkingDir & "temp.txt"
'Set default return value
boolReturn = False
'Create command line to ping and save results to a temp file
strCommand = "cmd /c ping.exe -n 1 -w 500 " & strName & " > """ & strTempFile & """"
'Execute the command
objShell.Run strCommand, 0, True
'Open the temp text file
Set objTempFile = objFSO.GetFile(strTempFile
Set objTS = objTempFile.OpenAsTextStre
'Loop through the temp file to see if "reply from" is found,
'if it is then the ping was successful
Do While objTs.AtEndOfStream <> True
strReadLine = objTs.ReadLine
If InStr(LCase(strReadLine), "reply from") > 0 Then
boolReturn = True
Exit Do
End If
Loop
'Close temp file and release objects
objTS.Close
objTempFile.Delete True
Set objTS = Nothing
Set objTempFile = Nothing
Set objShell = Nothing
Set objFSO = Nothing
'Return value
Ping = boolReturn
End Function
'===================
Regards,
Rob.
Hats off, Rob :) You *are* a genius!
RE PSTools, i meant psInfo (which was what the link was). My bad for not saying that
RE PSTools, i meant psInfo (which was what the link was). My bad for not saying that
Cool. Thanks for the info......cheers for the compliment.....
Rob.
Rob.
ASKER
Oh, silly me I should have known better that was too easy for Mr.G.
Rob, you are the man. Lets make it a little harder for you.
What if I want to run this script in conjunction with this one that you so kindly provided not long a go? This one, well you know what it does.
Thanks a million
Sean
Option Explicit
'On Error Resume Next
Dim WSHShell, WSHProcess, strUserName, strHostName, strCommand
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Set WSHShell = CreateObject("Wscript.Shel
Set WSHProcess = WSHShell.Environment("Proc
strUserName = WSHProcess("USERNAME")
strHostName = WSHProcess("COMPUTERNAME")
Dim objShell, strComputer, objWMIService, colComputerIP, IPConfig, intIPCount, strIPAddress, strFullIP
Dim objFSO, objFile, strOutputFile
Dim strContents, arrLinesInFile, intLineCount, intMaxLinesAllowed
strComputer = "."
Set objFSO = CreateObject("Scripting.Fi
Set objShell = CreateObject("WScript.Shel
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputerIP = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfig
For Each IPConfig in colComputerIP
If Not IsNull(IPConfig.IPAddress)
For intIPCount = LBound(IPConfig.IPAddress)
strIPAddress = strIPAddress & "IP Address: " & IPConfig.IPAddress(intIPCo
Next
End If
Next
If InStr(strIPAddress, "192.168.0.") > 0 Then
strFullIP = Mid(strIPAddress, InStr(strIPAddress, "192.168.0."), InStr(InStr(strIPAddress, "192.168.0."), strIPAddress, "~") - InStr(strIPAddress, "192.168.0."))
ElseIf InStr(strIPAddress, "192.168.250.") > 0 Then
strFullIP = Mid(strIPAddress, InStr(strIPAddress, "192.168.250."), InStr(InStr(strIPAddress, "192.168.250."), strIPAddress, "~") - InStr(strIPAddress, "192.168.250.0."))
Else
strFullIP = "UNKNOWN"
End If
If Len(strFullIP) > 1 And Right(strFullIP, 1) = "~" Then
strFullIP = Left(strFullIP, Len(strFullIP) - 1)
End If
' /////// Define the text file name as the name of the user //////////
strOutputFile = "\\corpfs01\UserLogins\" & strUserName & ".txt"
'On Error Resume Next
'/////// Open the user's text file for reading first to be able to count the number of lines ///////
'Set objFile = objFSO.OpenTextFile ("\\corpfs01\UserLogins\" & strOutputFile, ForAppending, True)
Set objFile = objFSO.OpenTextFile (strOutputFile, ForReading, True)
'////// Set this value to the maximum number of entries allowed per user's text file
'////// Set this value to 0 or -1 to have unlimited lines
intMaxLinesAllowed = -1
strContents = ""
On Error Resume Next
strContents = objFile.ReadAll
On Error GoTo 0
If Len(strContents) > 0 Then
arrLinesInFile = Split(strContents, vbCrLf)
If intMaxLinesAllowed > 0 Then
If UBound(arrLinesInFile) > (intMaxLinesAllowed - 1) Then
strContents = ""
For intLineCount = 0 To (intMaxLinesAllowed - 2)
strContents = strContents & arrLinesInFile(intLineCoun
Next
strContents = strContents & arrLinesInFile((intMaxLine
End If
End If
End If
'MsgBox "There are " & UBound(arrLinesInFile) & " lines in the file before adding 1."
Set objFile = objFSO.OpenTextFile (strOutputFile, ForWriting, True)
objFile.Write(Pad_String(s
Dim objNetwork, colDrives, strDrives, intDrive
Set objNetwork = CreateObject("WScript.Netw
Set colDrives = objNetwork.EnumNetworkDriv
strDrives = "Drives mapped:"
If colDrives.Count > 0 Then
For intDrive = 0 To colDrives.Count - 1 Step 2
strDrives = strDrives & VbCrLf & colDrives(intDrive) & " --> " & colDrives(intDrive + 1)
Next
Else
strDrives = "No drives are mapped."
End If
objFile.WriteLine vbCrLf & strDrives & vbCrLf
Dim objSysInfo, objUser, strGroups, intLevel, arrGroups, strResults, intCount, objMemberOf, objGroup, strGroupName, objNextGroup
Set objSysInfo = CreateObject("ADSystemInfo
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
strGroups = ""
intLevel = 0
GetMemberOfNames objUser, intLevel
strResults = Replace(objUser.Name, "CN=", "") & " is a member of: "
arrGroups = Split(strGroups, VbCrLf)
For intCount = LBound(arrGroups) To UBound(arrGroups)
If strResults = "" Then
strResults = arrGroups(intCount)
Else
strResults = strResults & VbCrLf & arrGroups(intCount)
End If
Next
objFile.WriteLine strResults & VbCrLf
objFile.Write strContents
objFile.Close
On Error Goto 0
Sub GetMemberOfNames(objObject
' This function can get caught in a loop if there is a circular
' group membership. There is a method of using a Dictionary object
' here: http://www.rlmueller.net/MemberOf.htm
' which checks if the group has been used before.
intLevel = intLevel + 1
' Retrieve ALL of the user groups that a user is a member of
On Error Resume Next
objMemberOf = objObjectToCheck.GetEx("Me
If Err.Number = 0 Then
On Error GoTo 0
For Each objGroup in objMemberOf
strGroupName = Left(Mid(objGroup, InStr(objGroup, "CN=") + 3),InStr(Mid(objGroup, InStr(objGroup, "CN=") + 3), ",") - 1)
If strGroups = "" Then
strGroups = String(intLevel, ">") & strGroupName
Else
strGroups = strGroups & VbCrLf & String(intLevel, ">") & strGroupName
End If
Set objNextGroup = GetObject("LDAP://" & objGroup)
GetMemberOfNames objNextGroup, intLevel
Next
intLevel = intLevel - 1
Else
intLevel = intLevel - 1
Err.Clear
On Error GoTo 0
End If
End Sub
'*************************
Function Pad_String(strOriginalStri
'Declare variants used in this function.
Dim intPadCount, strPadding
'Convert imput direction to lower case.
strDirection = LCase(strDirection)
'Trim input string if larger than pad length
If (Len(strOriginalString) > intTotalLengthRequired) Then
strOriginalString = Left(strOriginalString, intTotalLengthRequired)
End If
'Take first character if input pad character is more than a single character.
If (Len(strCharacterToPadWith
strCharacterToPadWith = Left(strCharacterToPadWith
End If
'Generate padding string
For intPadCount = 1 to intTotalLengthRequired - Len(strOriginalString)
strPadding = strCharacterToPadWith & strPadding
Next
If strDirection <> "left" And strDirection <> "right" Then
strDirection = "right"
End If
'Return padded string based on direction.
Select Case strDirection
Case "left"
Pad_String = strPadding & strOriginalString
Case "right"
Pad_String = strOriginalString & strPadding
End Select
End Function
'===============
Rob, you are the man. Lets make it a little harder for you.
What if I want to run this script in conjunction with this one that you so kindly provided not long a go? This one, well you know what it does.
Thanks a million
Sean
Option Explicit
'On Error Resume Next
Dim WSHShell, WSHProcess, strUserName, strHostName, strCommand
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Set WSHShell = CreateObject("Wscript.Shel
Set WSHProcess = WSHShell.Environment("Proc
strUserName = WSHProcess("USERNAME")
strHostName = WSHProcess("COMPUTERNAME")
Dim objShell, strComputer, objWMIService, colComputerIP, IPConfig, intIPCount, strIPAddress, strFullIP
Dim objFSO, objFile, strOutputFile
Dim strContents, arrLinesInFile, intLineCount, intMaxLinesAllowed
strComputer = "."
Set objFSO = CreateObject("Scripting.Fi
Set objShell = CreateObject("WScript.Shel
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputerIP = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfig
For Each IPConfig in colComputerIP
If Not IsNull(IPConfig.IPAddress)
For intIPCount = LBound(IPConfig.IPAddress)
strIPAddress = strIPAddress & "IP Address: " & IPConfig.IPAddress(intIPCo
Next
End If
Next
If InStr(strIPAddress, "192.168.0.") > 0 Then
strFullIP = Mid(strIPAddress, InStr(strIPAddress, "192.168.0."), InStr(InStr(strIPAddress, "192.168.0."), strIPAddress, "~") - InStr(strIPAddress, "192.168.0."))
ElseIf InStr(strIPAddress, "192.168.250.") > 0 Then
strFullIP = Mid(strIPAddress, InStr(strIPAddress, "192.168.250."), InStr(InStr(strIPAddress, "192.168.250."), strIPAddress, "~") - InStr(strIPAddress, "192.168.250.0."))
Else
strFullIP = "UNKNOWN"
End If
If Len(strFullIP) > 1 And Right(strFullIP, 1) = "~" Then
strFullIP = Left(strFullIP, Len(strFullIP) - 1)
End If
' /////// Define the text file name as the name of the user //////////
strOutputFile = "\\corpfs01\UserLogins\" & strUserName & ".txt"
'On Error Resume Next
'/////// Open the user's text file for reading first to be able to count the number of lines ///////
'Set objFile = objFSO.OpenTextFile ("\\corpfs01\UserLogins\" & strOutputFile, ForAppending, True)
Set objFile = objFSO.OpenTextFile (strOutputFile, ForReading, True)
'////// Set this value to the maximum number of entries allowed per user's text file
'////// Set this value to 0 or -1 to have unlimited lines
intMaxLinesAllowed = -1
strContents = ""
On Error Resume Next
strContents = objFile.ReadAll
On Error GoTo 0
If Len(strContents) > 0 Then
arrLinesInFile = Split(strContents, vbCrLf)
If intMaxLinesAllowed > 0 Then
If UBound(arrLinesInFile) > (intMaxLinesAllowed - 1) Then
strContents = ""
For intLineCount = 0 To (intMaxLinesAllowed - 2)
strContents = strContents & arrLinesInFile(intLineCoun
Next
strContents = strContents & arrLinesInFile((intMaxLine
End If
End If
End If
'MsgBox "There are " & UBound(arrLinesInFile) & " lines in the file before adding 1."
Set objFile = objFSO.OpenTextFile (strOutputFile, ForWriting, True)
objFile.Write(Pad_String(s
Dim objNetwork, colDrives, strDrives, intDrive
Set objNetwork = CreateObject("WScript.Netw
Set colDrives = objNetwork.EnumNetworkDriv
strDrives = "Drives mapped:"
If colDrives.Count > 0 Then
For intDrive = 0 To colDrives.Count - 1 Step 2
strDrives = strDrives & VbCrLf & colDrives(intDrive) & " --> " & colDrives(intDrive + 1)
Next
Else
strDrives = "No drives are mapped."
End If
objFile.WriteLine vbCrLf & strDrives & vbCrLf
Dim objSysInfo, objUser, strGroups, intLevel, arrGroups, strResults, intCount, objMemberOf, objGroup, strGroupName, objNextGroup
Set objSysInfo = CreateObject("ADSystemInfo
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
strGroups = ""
intLevel = 0
GetMemberOfNames objUser, intLevel
strResults = Replace(objUser.Name, "CN=", "") & " is a member of: "
arrGroups = Split(strGroups, VbCrLf)
For intCount = LBound(arrGroups) To UBound(arrGroups)
If strResults = "" Then
strResults = arrGroups(intCount)
Else
strResults = strResults & VbCrLf & arrGroups(intCount)
End If
Next
objFile.WriteLine strResults & VbCrLf
objFile.Write strContents
objFile.Close
On Error Goto 0
Sub GetMemberOfNames(objObject
' This function can get caught in a loop if there is a circular
' group membership. There is a method of using a Dictionary object
' here: http://www.rlmueller.net/MemberOf.htm
' which checks if the group has been used before.
intLevel = intLevel + 1
' Retrieve ALL of the user groups that a user is a member of
On Error Resume Next
objMemberOf = objObjectToCheck.GetEx("Me
If Err.Number = 0 Then
On Error GoTo 0
For Each objGroup in objMemberOf
strGroupName = Left(Mid(objGroup, InStr(objGroup, "CN=") + 3),InStr(Mid(objGroup, InStr(objGroup, "CN=") + 3), ",") - 1)
If strGroups = "" Then
strGroups = String(intLevel, ">") & strGroupName
Else
strGroups = strGroups & VbCrLf & String(intLevel, ">") & strGroupName
End If
Set objNextGroup = GetObject("LDAP://" & objGroup)
GetMemberOfNames objNextGroup, intLevel
Next
intLevel = intLevel - 1
Else
intLevel = intLevel - 1
Err.Clear
On Error GoTo 0
End If
End Sub
'*************************
Function Pad_String(strOriginalStri
'Declare variants used in this function.
Dim intPadCount, strPadding
'Convert imput direction to lower case.
strDirection = LCase(strDirection)
'Trim input string if larger than pad length
If (Len(strOriginalString) > intTotalLengthRequired) Then
strOriginalString = Left(strOriginalString, intTotalLengthRequired)
End If
'Take first character if input pad character is more than a single character.
If (Len(strCharacterToPadWith
strCharacterToPadWith = Left(strCharacterToPadWith
End If
'Generate padding string
For intPadCount = 1 to intTotalLengthRequired - Len(strOriginalString)
strPadding = strCharacterToPadWith & strPadding
Next
If strDirection <> "left" And strDirection <> "right" Then
strDirection = "right"
End If
'Return padded string based on direction.
Select Case strDirection
Case "left"
Pad_String = strPadding & strOriginalString
Case "right"
Pad_String = strOriginalString & strPadding
End Select
End Function
'===============
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Rob The Genius,
What can I say you are the best. If it is not too much trouble I would preffer for the CSV file to be appended not overwriten .
I will try to find something harder next time.
Thanks a million, much appreciated.
Sean
What can I say you are the best. If it is not too much trouble I would preffer for the CSV file to be appended not overwriten .
I will try to find something harder next time.
Thanks a million, much appreciated.
Sean
But appending could get very large very quickly.......are you sure? If so, just change this:
Set objCSVFile = objFSO.CreateTextFile(strC
to this:
Set objCSVFile = objFSO.OpenTextFile(strCSV
Regards,
Rob.
Set objCSVFile = objFSO.CreateTextFile(strC
to this:
Set objCSVFile = objFSO.OpenTextFile(strCSV
Regards,
Rob.
ASKER
You are of course correct, but I cant think of a better way of keeping track of changes and there are ocasions that a user will login different computers. Anyway, It will be for a short time untill I can lock things down.
Thank you again
Sean
Thank you again
Sean
No problem Sean.
Thanks for the grade. FYI, the only reason I could offer this one so quickly is because I had built the exact same thing for our PC Refresh program, where I programmatically inventoried the PCs, then replaced them, and we had a record of what used to be on a user's PC. The script itself took me some weeks to get right, so you're lucky you didn't have to wait that long! ;-)
Regards,
Rob.
Thanks for the grade. FYI, the only reason I could offer this one so quickly is because I had built the exact same thing for our PC Refresh program, where I programmatically inventoried the PCs, then replaced them, and we had a record of what used to be on a user's PC. The script itself took me some weeks to get right, so you're lucky you didn't have to wait that long! ;-)
Regards,
Rob.
Sean, here is my part of the script again, with the ability to append to the existing CSV file, as well as insert a blank line and the date and time upon each run:
'*************************
' GetSoftwareDetails_On_Logi
'
' This function uses the following Reg Key:
' SOFTWARE\Microsoft\Windows
' to return the list of programs that are listed in the Add / Remove
' Programs applet of the control panel.
'
' It also uses a WQL query of "SELECT * FROM Win32_Product"
' to obtain the list of software products that have been installed
' using the Microsoft Windows Installer.
'*************************
Option Explicit
Dim objNetwork
Dim strWorkingDir
Dim strAllPCsFile, objAllPCsFile, strSearchResultsFile, strOutputFile
Dim strSinglePC, strComputer, arrSinglePC, strKey, strSubKey, strUserName
Dim colSystemInfo, objItem, strOS_Caption, strOS_SPVersion, strOS_VerNumber
Dim objRegistry
Dim arrSubKeys()
Dim strDisplayName, strDisplayVersion, strInstallLocation
Dim strScriptName, strScriptPath, strFileOutputPath
Dim strAllDetails, objExec, strActivePCs, arrActivePCs, strInactivePCs
Dim arrResultsRows, arrResultsTable, intRowNum, intColNum
Dim objWMIService, colAllSoftware, objSoftware, colComputer, objComputer
Dim boolShowMSKBPatches
Dim boolPinged
Dim arrComputerPrograms 'Global variable to hold the computer programs per computer
Const HKEY_LOCAL_MACHINE = &H80000002
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
strWorkingDir = Replace(WScript.ScriptFull
'boolShowMSKBPatches = MsgBox("Do you want to display Micorosoft KnowledgeBase Patches?", vbYesNo, "Display Patches?")
boolShowMSKBPatches = vbNo
If boolShowMSKBPatches = vbYes Then
boolShowMSKBPatches = True
Else
boolShowMSKBPatches = False
End If
strAllPCsFile = "Replacement_PCs.txt"
strSearchResultsFile = "Results.txt"
strOutputFile = "InactivePCs.txt"
strInactivePCs = ""
strAllDetails = ""
Set objNetwork = CreateObject("WScript.Netw
strComputer = objNetwork.ComputerName
Set objNetwork = Nothing
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputer = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strUserName = "User Name: " & objComputer.UserName
Next
Set colSystemInfo = objWMIService.ExecQuery _
("Select * from Win32_OperatingSystem",,48
For Each objItem in colSystemInfo
strOS_Caption = "Caption: " & objItem.Caption
strOS_SPVersion = "SP Version: " & objItem.CSDVersion
strOS_VerNumber = "Version Number: " & objItem.Version
Next
If strAllDetails = "" Then
strAllDetails = strAllDetails & "Time: " & Now & ";;;" & VbCrLf & _
"Operating System: " & strOS_Caption & ";;;" & VbCrLf & _
"Service Pack: " & strOS_SPVersion & ";;;" & VbCrLf & _
"Version: " & strOS_VerNumber & ";;;"
Else
strAllDetails = strAllDetails & VbCrLf & "Time: " & Now & ";;;" & VbCrLf & _
"Operating System: " & strOS_Caption & ";;;" & VbCrLf & _
"Service Pack: " & strOS_SPVersion & ";;;" & VbCrLf & _
"Version: " & strOS_VerNumber & ";;;"
End If
'WScript.Echo strComputer & " responded to ping."
' **************************
' ********** START OF FIRST METHOD - Add / Remove Programs ************
' **************************
strKey = "SOFTWARE\Microsoft\Window
'MsgBox "Ping successful on: " & strComputer
On Error Resume Next
Set objRegistry = GetObject("winmgmts:" & _
"{impersonationLevel=Imper
strComputer & "\root\default:StdRegProv"
If Err.Number <> 0 Then
'MsgBox "There was a problem connecting to: " & strComputer & "."
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
Err.Clear
On Error GoTo 0
Else
objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubKeys
On Error Resume Next
For Each strSubKey In arrSubKeys
objRegistry.GetStringValue
objRegistry.GetStringValue
objRegistry.GetStringValue
'strAllDetails = strAllDetails & strComputer & ";" & strSubKey & ";" & strDisplayName & ";" & strDisplayVersion & VbCrLf
If strDisplayName <> "" Then
If boolShowMSKBPatches = False Then
If InStr(strDisplayName, " KB") = 0 And InStr(strDisplayName, "(KB") = 0 Then
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
Else
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
End If
strDisplayName = vbEmpty
strDisplayVersion = vbEmpty
strInstallLocation = vbEmpty
Next
On Error GoTo 0
' **************************
' *********** END OF FIRST METHOD - Add / Remove Programs ***************
' **************************
' *********** START OF SECOND METHOD - Windows Installer ****************
' **************************
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=imper
' & strComputer & "\root\cimv2")
Set colAllSoftware = objWMIService.ExecQuery _
("Select * from Win32_Product")
On Error Resume Next
For Each objSoftware in colAllSoftware
'strAllSoftware = strAllSoftware & "Name: " & objSoftware.Name & vbcrlf & "Version: " & objSoftware.Version & vbcrlf
If strAllDetails = "" Then
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
Else
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
End If
Next
On Error GoTo 0
' **************************
' *********** END OF SECOND METHOD - Windows Installer *****************
' **************************
strActivePCs = strActivePCs & strComputer & ";"
End If
If Right(strActivePCs, 1) = ";" Then
strActivePCs = Left(strActivePCs, Len(strActivePCs) - 1)
End If
arrActivePCs = Split(strActivePCs, ";")
' ********** Create the main Results Table array ************
If strAllDetails = "" Then
'MsgBox "There are no results to display. Please check that any PCs are active."
WScript.Quit
End If
arrResultsRows = Split(strAllDetails, VbCrLf)
'MsgBox arrResultsRows(UBound(arrR
'MsgBox Split(arrResultsRows(UBoun
ReDim arrResultsTable(UBound(arr
'MsgBox "STRING:" & Right(strAllDetails, 100) & ":STRING"
For intRowNum = LBound(arrResultsRows) To UBound(arrResultsRows)
For intColNum = LBound(Split(arrResultsRow
arrResultsTable(intRowNum,
Next
Next
' ********** End of creating the main Results Table array **************
Output_To_CSV
'MsgBox "Finished."
'*************************
Sub Output_To_CSV
Dim objFSO, objCSVFile, strCSVPath, objNetwork, strUserName
Set objNetwork = CreateObject("WScript.Netw
Set objFSO = CreateObject("Scripting.Fi
strUserName = objNetwork.UserName
strCSVPath = "\\corpfs01\UserLogins\" & strUserName & "_Apps.csv"
strCSVPath = "\\ntfp\userlogins$\" & strUserName & "_Apps.csv"
'Set objCSVFile = objFSO.CreateTextFile(strC
Set objCSVFile = objFSO.OpenTextFile(strCSV
If IsArray(arrResultsTable) = True Then
Show_Computer_Programs objCSVFile
Else
'MsgBox "No programs have been retrieved. Cannot output to CSV."
End If
objCSVFile.Close
Set objCSVFile = Nothing
Set objFSO = Nothing
Set objNetwork = Nothing
End Sub
'*************************
Sub Write_CSV_Header_Row(objCS
Dim arrFields
Dim intColCounter, strLastColumn
arrFields = Array("Computer", "Owner", "Software", "Version")
For intColCounter = LBound(arrFields) To UBound(arrFields)
'objExcelApp.ActiveSheet.R
If intColCounter = 0 Then
objCSVFile.Write """" & arrFields(intColCounter) & """"
Else
objCSVFile.Write "," & """" & arrFields(intColCounter) & """"
End If
Next
End Sub
'*************************
Sub Show_Computer_Programs(obj
Dim intProgramCounter, intComputerProgramCount, intRowCounter, intColCounter, intActivePCCounter
If IsArray(arrResultsTable) = True Then
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
intComputerProgramCount = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
'MsgBox "Table: " & arrResultsTable(intProgram
If arrResultsTable(intProgram
intComputerProgramCount = intComputerProgramCount + 1
End If
Next
ReDim arrComputerPrograms(intCom
intRowCounter = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
If arrResultsTable(intProgram
For intColCounter = LBound(Split(arrResultsRow
arrComputerPrograms(intRow
Next
intRowCounter = intRowCounter + 1
End If
Next
If UBound(arrComputerPrograms
objCSVFile.Write """Date"",""" & Date & """,""Time"",""" & Time & """" & vbCrLf
Display_Single_Computer_Pr
Else
Write_CSV_Header_Row objCSVFile
objCSVFile.Write """Date"",""" & Date & """,""Time"",""" & Time & """" & vbCrLf
End If
Next
objCSVFile.Write VbCrLf & VbCrLf
Else
'MsgBox "No programs have been retrieved."
End If
End Sub
'*************************
Sub Display_Single_Computer_Pr
Dim intRowCounter, intColCounter
Write_CSV_Header_Row(objCS
For intRowCounter = LBound(arrComputerPrograms
For intColCounter = LBound(Split(arrResultsRow
If intColCounter = 0 Then
objCSVFile.Write VbCrLf & """" & arrComputerPrograms(intRow
Else
objCSVFile.Write "," & """" & arrComputerPrograms(intRow
End If
Next
Next
End Sub
Regards,
Rob.
'*************************
' GetSoftwareDetails_On_Logi
'
' This function uses the following Reg Key:
' SOFTWARE\Microsoft\Windows
' to return the list of programs that are listed in the Add / Remove
' Programs applet of the control panel.
'
' It also uses a WQL query of "SELECT * FROM Win32_Product"
' to obtain the list of software products that have been installed
' using the Microsoft Windows Installer.
'*************************
Option Explicit
Dim objNetwork
Dim strWorkingDir
Dim strAllPCsFile, objAllPCsFile, strSearchResultsFile, strOutputFile
Dim strSinglePC, strComputer, arrSinglePC, strKey, strSubKey, strUserName
Dim colSystemInfo, objItem, strOS_Caption, strOS_SPVersion, strOS_VerNumber
Dim objRegistry
Dim arrSubKeys()
Dim strDisplayName, strDisplayVersion, strInstallLocation
Dim strScriptName, strScriptPath, strFileOutputPath
Dim strAllDetails, objExec, strActivePCs, arrActivePCs, strInactivePCs
Dim arrResultsRows, arrResultsTable, intRowNum, intColNum
Dim objWMIService, colAllSoftware, objSoftware, colComputer, objComputer
Dim boolShowMSKBPatches
Dim boolPinged
Dim arrComputerPrograms 'Global variable to hold the computer programs per computer
Const HKEY_LOCAL_MACHINE = &H80000002
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
strWorkingDir = Replace(WScript.ScriptFull
'boolShowMSKBPatches = MsgBox("Do you want to display Micorosoft KnowledgeBase Patches?", vbYesNo, "Display Patches?")
boolShowMSKBPatches = vbNo
If boolShowMSKBPatches = vbYes Then
boolShowMSKBPatches = True
Else
boolShowMSKBPatches = False
End If
strAllPCsFile = "Replacement_PCs.txt"
strSearchResultsFile = "Results.txt"
strOutputFile = "InactivePCs.txt"
strInactivePCs = ""
strAllDetails = ""
Set objNetwork = CreateObject("WScript.Netw
strComputer = objNetwork.ComputerName
Set objNetwork = Nothing
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=imper
Set colComputer = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strUserName = "User Name: " & objComputer.UserName
Next
Set colSystemInfo = objWMIService.ExecQuery _
("Select * from Win32_OperatingSystem",,48
For Each objItem in colSystemInfo
strOS_Caption = "Caption: " & objItem.Caption
strOS_SPVersion = "SP Version: " & objItem.CSDVersion
strOS_VerNumber = "Version Number: " & objItem.Version
Next
If strAllDetails = "" Then
strAllDetails = strAllDetails & "Time: " & Now & ";;;" & VbCrLf & _
"Operating System: " & strOS_Caption & ";;;" & VbCrLf & _
"Service Pack: " & strOS_SPVersion & ";;;" & VbCrLf & _
"Version: " & strOS_VerNumber & ";;;"
Else
strAllDetails = strAllDetails & VbCrLf & "Time: " & Now & ";;;" & VbCrLf & _
"Operating System: " & strOS_Caption & ";;;" & VbCrLf & _
"Service Pack: " & strOS_SPVersion & ";;;" & VbCrLf & _
"Version: " & strOS_VerNumber & ";;;"
End If
'WScript.Echo strComputer & " responded to ping."
' **************************
' ********** START OF FIRST METHOD - Add / Remove Programs ************
' **************************
strKey = "SOFTWARE\Microsoft\Window
'MsgBox "Ping successful on: " & strComputer
On Error Resume Next
Set objRegistry = GetObject("winmgmts:" & _
"{impersonationLevel=Imper
strComputer & "\root\default:StdRegProv"
If Err.Number <> 0 Then
'MsgBox "There was a problem connecting to: " & strComputer & "."
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
Err.Clear
On Error GoTo 0
Else
objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubKeys
On Error Resume Next
For Each strSubKey In arrSubKeys
objRegistry.GetStringValue
objRegistry.GetStringValue
objRegistry.GetStringValue
'strAllDetails = strAllDetails & strComputer & ";" & strSubKey & ";" & strDisplayName & ";" & strDisplayVersion & VbCrLf
If strDisplayName <> "" Then
If boolShowMSKBPatches = False Then
If InStr(strDisplayName, " KB") = 0 And InStr(strDisplayName, "(KB") = 0 Then
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
Else
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
End If
strDisplayName = vbEmpty
strDisplayVersion = vbEmpty
strInstallLocation = vbEmpty
Next
On Error GoTo 0
' **************************
' *********** END OF FIRST METHOD - Add / Remove Programs ***************
' **************************
' *********** START OF SECOND METHOD - Windows Installer ****************
' **************************
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=imper
' & strComputer & "\root\cimv2")
Set colAllSoftware = objWMIService.ExecQuery _
("Select * from Win32_Product")
On Error Resume Next
For Each objSoftware in colAllSoftware
'strAllSoftware = strAllSoftware & "Name: " & objSoftware.Name & vbcrlf & "Version: " & objSoftware.Version & vbcrlf
If strAllDetails = "" Then
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
Else
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
End If
Next
On Error GoTo 0
' **************************
' *********** END OF SECOND METHOD - Windows Installer *****************
' **************************
strActivePCs = strActivePCs & strComputer & ";"
End If
If Right(strActivePCs, 1) = ";" Then
strActivePCs = Left(strActivePCs, Len(strActivePCs) - 1)
End If
arrActivePCs = Split(strActivePCs, ";")
' ********** Create the main Results Table array ************
If strAllDetails = "" Then
'MsgBox "There are no results to display. Please check that any PCs are active."
WScript.Quit
End If
arrResultsRows = Split(strAllDetails, VbCrLf)
'MsgBox arrResultsRows(UBound(arrR
'MsgBox Split(arrResultsRows(UBoun
ReDim arrResultsTable(UBound(arr
'MsgBox "STRING:" & Right(strAllDetails, 100) & ":STRING"
For intRowNum = LBound(arrResultsRows) To UBound(arrResultsRows)
For intColNum = LBound(Split(arrResultsRow
arrResultsTable(intRowNum,
Next
Next
' ********** End of creating the main Results Table array **************
Output_To_CSV
'MsgBox "Finished."
'*************************
Sub Output_To_CSV
Dim objFSO, objCSVFile, strCSVPath, objNetwork, strUserName
Set objNetwork = CreateObject("WScript.Netw
Set objFSO = CreateObject("Scripting.Fi
strUserName = objNetwork.UserName
strCSVPath = "\\corpfs01\UserLogins\" & strUserName & "_Apps.csv"
strCSVPath = "\\ntfp\userlogins$\" & strUserName & "_Apps.csv"
'Set objCSVFile = objFSO.CreateTextFile(strC
Set objCSVFile = objFSO.OpenTextFile(strCSV
If IsArray(arrResultsTable) = True Then
Show_Computer_Programs objCSVFile
Else
'MsgBox "No programs have been retrieved. Cannot output to CSV."
End If
objCSVFile.Close
Set objCSVFile = Nothing
Set objFSO = Nothing
Set objNetwork = Nothing
End Sub
'*************************
Sub Write_CSV_Header_Row(objCS
Dim arrFields
Dim intColCounter, strLastColumn
arrFields = Array("Computer", "Owner", "Software", "Version")
For intColCounter = LBound(arrFields) To UBound(arrFields)
'objExcelApp.ActiveSheet.R
If intColCounter = 0 Then
objCSVFile.Write """" & arrFields(intColCounter) & """"
Else
objCSVFile.Write "," & """" & arrFields(intColCounter) & """"
End If
Next
End Sub
'*************************
Sub Show_Computer_Programs(obj
Dim intProgramCounter, intComputerProgramCount, intRowCounter, intColCounter, intActivePCCounter
If IsArray(arrResultsTable) = True Then
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
intComputerProgramCount = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
'MsgBox "Table: " & arrResultsTable(intProgram
If arrResultsTable(intProgram
intComputerProgramCount = intComputerProgramCount + 1
End If
Next
ReDim arrComputerPrograms(intCom
intRowCounter = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
If arrResultsTable(intProgram
For intColCounter = LBound(Split(arrResultsRow
arrComputerPrograms(intRow
Next
intRowCounter = intRowCounter + 1
End If
Next
If UBound(arrComputerPrograms
objCSVFile.Write """Date"",""" & Date & """,""Time"",""" & Time & """" & vbCrLf
Display_Single_Computer_Pr
Else
Write_CSV_Header_Row objCSVFile
objCSVFile.Write """Date"",""" & Date & """,""Time"",""" & Time & """" & vbCrLf
End If
Next
objCSVFile.Write VbCrLf & VbCrLf
Else
'MsgBox "No programs have been retrieved."
End If
End Sub
'*************************
Sub Display_Single_Computer_Pr
Dim intRowCounter, intColCounter
Write_CSV_Header_Row(objCS
For intRowCounter = LBound(arrComputerPrograms
For intColCounter = LBound(Split(arrResultsRow
If intColCounter = 0 Then
objCSVFile.Write VbCrLf & """" & arrComputerPrograms(intRow
Else
objCSVFile.Write "," & """" & arrComputerPrograms(intRow
End If
Next
Next
End Sub
Regards,
Rob.
I have a thread https://www.experts-exchange.com/questions/24028067/software-on-domain.html, Robs code is exactly what I need.
However rather then input computer names with a text fields I have been trying to get it to run through computers on the domain?, hard?, possible?
However rather then input computer names with a text fields I have been trying to get it to run through computers on the domain?, hard?, possible?
Hi there....that *could* be possible, but it would require a bit of a re-write, and more testing....
It would be easier to use the following code to list every computer from your domain into a text file for you. That way, you can easily run the script against every computer in your domain.
Regards,
Rob.
It would be easier to use the following code to list every computer from your domain into a text file for you. That way, you can easily run the script against every computer in your domain.
Regards,
Rob.
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
strDomain = objNetwork.UserDomain
Set objComputers = GetObject("WinNT://" & strDomain)
objComputers.Filter = Array("Computer")
strResults = ""
For Each objComputer In objComputers
If strResults = "" Then
strResults = objComputer.Name
Else
strResults = strResults & VbCrLf & objComputer.Name
End IF
Next
Set objFile = objFSO.CreateTextFile("computers.txt", True)
objFile.Write strResults
objFile.Close
Set objFile = Nothing
MsgBox "Done"
Or, to get a list of computers from a specific OU only, you can use this.
Regards,
Rob.
Regards,
Rob.
On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strOU = "OU=Computers,OU=Main Site,"
If Trim(strOU) <> "" Then
If Right(strOU, 1) <> "," Then strOU = strOU & ","
Else
strOU = ""
End If
objCommand.CommandText = _
"SELECT Name FROM 'LDAP://" & strOU & strDNSDomain & "' WHERE objectCategory='computer'"
Set objRecordSet = objCommand.Execute
strResults = ""
Do Until objRecordSet.EOF
If strResults = "" Then
strResults = objRecordSet.Fields("Name").Value
Else
strResults = strResults & VbCrLf & objRecordSet.Fields("Name").Value
End IF
objRecordSet.MoveNext
Loop
Set objFile = objFSO.CreateTextFile("computers.txt", True)
objFile.Write strResults
objFile.Close
Set objFile = Nothing
MsgBox "Done"
Guys I am having one problem with this code,
if there are computers in the textfield which are offline which there are inevitably,
the script just stops running rather then move on to the next computer in the notepad
if there are computers in the textfield which are offline which there are inevitably,
the script just stops running rather then move on to the next computer in the notepad
Hi there....the script does ping the machines, but doesn't have any error checking around the GetObject call, which is probably what's failing....I can add that if you like....
Which comment ID from here has the code that you're using?
Regards,
Rob.
Which comment ID from here has the code that you're using?
Regards,
Rob.
ASKER
Hi,
I run this script after a login script. So every time a user logs in the script runs. Its has been working with no problems for almost a year. Thank you Rob, i hope all is well.
Sean
I run this script after a login script. So every time a user logs in the script runs. Its has been working with no problems for almost a year. Thank you Rob, i hope all is well.
Sean
G'day Sean, yep, I'm doing great, thanks for asking...
>> I run this script after a login script
That depends on which "version" of the code you use. Original code I posted in comment ID: 20838080 can be used "on demand", whereas the latest code in comment ID: 20871577 is designed as a logon script.
Regards,
Rob.
>> I run this script after a login script
That depends on which "version" of the code you use. Original code I posted in comment ID: 20838080 can be used "on demand", whereas the latest code in comment ID: 20871577 is designed as a logon script.
Regards,
Rob.
Hi Rob even i get the error. Can you tell which Version i could use to to export them to an excel without that error.
Hi Rob even i get the error. Can you tell which Version i could use to to export them to an excel without that error.
Which version are you using, and what line is the error on?
Rob.
Rob.
Hi Rob i am using this version
ID: 20838080
ID: 20838080
Hi Rob i am using this version
ID: 20838080
ID: 20838080
Hmmm....do you actually receive an error....I run it fine without it stopping....but it does take some time! Does the WScript.exe process actually stop? Can you see it in Task Manager?
It has error checking when making the WMI connection, in case WMI isn't working, and it checks for a ping response as well....
Rob.
It has error checking when making the WMI connection, in case WMI isn't working, and it checks for a ping response as well....
Rob.
I am using 20838080,
works perfect if I am using a text document with computer in it that are all on the network.
But if i use it with a computer thats not on the network anymore I get the error below.
Windows Script Host
Error : The remote server machine does not exist or is unavailable 'GetObject'
Code: 800A01CE
Source: Microsoft VBScript runtime error
works perfect if I am using a text document with computer in it that are all on the network.
But if i use it with a computer thats not on the network anymore I get the error below.
Windows Script Host
Error : The remote server machine does not exist or is unavailable 'GetObject'
Code: 800A01CE
Source: Microsoft VBScript runtime error
Rob I get this error
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
I am using the code in here
ID: 20838080
Rob i am posting a related Q Now. Please have a look at it...
https://www.experts-exchange.com/questions/24054393/Software-Inventory-Scan-all-machines-in-a-txt-file-and-get-the-results-to-an-Excel.html
This to ease the running on a lot of machines....
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
I am using the code in here
ID: 20838080
Rob i am posting a related Q Now. Please have a look at it...
https://www.experts-exchange.com/questions/24054393/Software-Inventory-Scan-all-machines-in-a-txt-file-and-get-the-results-to-an-Excel.html
This to ease the running on a lot of machines....
Hi guys, you're right....there was no error checking on line 66.....it is now treated as an inactive PC.
Regards,
Rob.
Regards,
Rob.
'===================
'********************************************************************
' This function uses the following Reg Key:
' SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\
' to return the list of programs that are listed in the Add / Remove
' Programs applet of the control panel.
'
' GetOfficeDetails.vbs uses a WQL query of "SELECT * FROM Win32_Product"
' to obtain the list of software products that have been installed
' using the Microsoft Windows Installer.
'********************************************************************
Option Explicit
Dim strWorkingDir
Dim strAllPCsFile, objAllPCsFile, strSearchResultsFile, strOutputFile
Dim strSinglePC, strComputer, arrSinglePC, strKey, strSubKey, strUserName
Dim objRegistry
Dim arrSubKeys()
Dim strDisplayName, strDisplayVersion, strInstallLocation
Dim strScriptName, strScriptPath, strFileOutputPath
Dim strAllDetails, objFSO, objExec, strActivePCs, arrActivePCs, strInactivePCs
Dim arrResultsRows, arrResultsTable, intRowNum, intColNum
Dim objWMIService, colAllSoftware, objSoftware, colComputer, objComputer
Dim boolShowMSKBPatches
Dim boolPinged
Dim arrComputerPrograms 'Global variable to hold the computer programs per computer
Const HKEY_LOCAL_MACHINE = &H80000002
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
strWorkingDir = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
'MsgBox strWorkingDir
If Left(strWorkingDir, 2) = "\\" Then
MsgBox "Please run this program from a network drive.", vbOKOnly, "Error"
WScript.Quit
End If
boolShowMSKBPatches = MsgBox("Do you want to display Micorosoft KnowledgeBase Patches?", vbYesNo, "Display Patches?")
If boolShowMSKBPatches = vbYes Then
boolShowMSKBPatches = True
Else
boolShowMSKBPatches = False
End If
'MsgBox boolShowMSKBPatches
strAllPCsFile = "Computers.txt"
strSearchResultsFile = "Results.txt"
strOutputFile = "InactivePCs.txt"
strInactivePCs = ""
strAllDetails = ""
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objAllPCsFile = objFSO.OpenTextFile(strAllPCsFile, intForReading)
While Not objAllPCsFile.AtEndOfStream
strComputer = objAllPCsFile.ReadLine
'MsgBox "About to ping: " & strComputer
boolPinged = Ping(strComputer)
If boolPinged = True Then
On Error Resume Next
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
If Err.Number = 0 Then
On Error GoTo 0
Set colComputer = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
For Each objComputer in colComputer
strUserName = "User Name: " & objComputer.UserName
Next
'WScript.Echo strComputer & " responded to ping."
' **********************************************************************
' ********** START OF FIRST METHOD - Add / Remove Programs ************
' **********************************************************************
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall"
'MsgBox "Ping successful on: " & strComputer
On Error Resume Next
Set objRegistry = GetObject("winmgmts:" & _
"{impersonationLevel=Impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
If Err.Number <> 0 Then
MsgBox "There was a problem connecting to: " & strComputer & "."
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
Err.Clear
On Error GoTo 0
Else
objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKey, arrSubKeys
On Error Resume Next
For Each strSubKey In arrSubKeys
objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKey & "\" & strSubKey, "DisplayName", strDisplayName
objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKey & "\" & strSubKey, "DisplayVersion", strDisplayVersion
objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKey & "\" & strSubKey, "InstallLocation", strInstallLocation
'strAllDetails = strAllDetails & strComputer & ";" & strSubKey & ";" & strDisplayName & ";" & strDisplayVersion & VbCrLf
If strDisplayName <> "" Then
If boolShowMSKBPatches = False Then
If InStr(strDisplayName, " KB") = 0 And InStr(strDisplayName, "(KB") = 0 Then
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
Else
If strAllDetails = "" Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
Else
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & strDisplayName & ";" & strDisplayVersion
End If
End If
End If
strDisplayName = vbEmpty
strDisplayVersion = vbEmpty
strInstallLocation = vbEmpty
Next
On Error GoTo 0
' **********************************************************************
' *********** END OF FIRST METHOD - Add / Remove Programs ***************
' **********************************************************************
' *********** START OF SECOND METHOD - Windows Installer ****************
' **********************************************************************
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=impersonate}!\\" _
' & strComputer & "\root\cimv2")
Set colAllSoftware = objWMIService.ExecQuery _
("Select * from Win32_Product")
On Error Resume Next
For Each objSoftware in colAllSoftware
'strAllSoftware = strAllSoftware & "Name: " & objSoftware.Name & vbcrlf & "Version: " & objSoftware.Version & vbcrlf
If strAllDetails = "" Then
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
Else
If InStr(strAllDetails, ";" & objSoftware.Name & ";") = 0 Then
strAllDetails = strAllDetails & VbCrLf & strComputer & ";" & strUserName & ";" & objSoftware.Name & ";" & objSoftware.Version
End If
End If
Next
On Error GoTo 0
' **********************************************************************
' *********** END OF SECOND METHOD - Windows Installer *****************
' **********************************************************************
strActivePCs = strActivePCs & strComputer & ";"
End If
Else
Err.Clear
On Error GoTo 0
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
End If
Else
If strInactivePCs = "" Then
strInactivePCs = strSinglePC
Else
strInactivePCs = strInactivePCs & vbCrLf & strSinglePC
End If
End If
Wend
If Right(strActivePCs, 1) = ";" Then
strActivePCs = Left(strActivePCs, Len(strActivePCs) - 1)
End If
arrActivePCs = Split(strActivePCs, ";")
' ********** Create the main Results Table array ************
If strAllDetails = "" Then
MsgBox "There are no results to display. Please check that any PCs are active."
WScript.Quit
End If
arrResultsRows = Split(strAllDetails, VbCrLf)
'MsgBox arrResultsRows(UBound(arrResultsRows))
'MsgBox Split(arrResultsRows(UBound(arrResultsRows)), ";")(0)
ReDim arrResultsTable(UBound(arrResultsRows), UBound(Split(arrResultsRows(0), ";")))
'MsgBox "STRING:" & Right(strAllDetails, 100) & ":STRING"
For intRowNum = LBound(arrResultsRows) To UBound(arrResultsRows)
For intColNum = LBound(Split(arrResultsRows(0), ";")) To UBound(Split(arrResultsRows(0), ";"))
'MsgBox intRowNum & ":" & intColNum
'If IsDate(Split(arrResultsRows(intRowNum), ";")(intColNum)) = False Then
arrResultsTable(intRowNum, intColNum) = Split(arrResultsRows(intRowNum), ";")(intColNum)
'Else
' arrResultsTable(intRowNum, intColNum) = CDate(Split(arrResultsRows(intRowNum), ";")(intColNum))
'End If
Next
Next
' ********** End of creating the main Results Table array **************
Output_To_Excel
Dim objFS
Dim objOutputFile
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFS.CreateTextFile(strOutputFile, True)
objOutputFile.Write(strInactivePCs)
objOutputFile.Close
MsgBox "InactivePCs have been recorded." & vbcrlf & "Please see " & strOutputFile & ".", vbOKOnly, "Output Finished"
'*************************************************************
Sub Output_To_Excel
Dim objExcel, objExcelWorkBook, intSheetCount
Dim strAllPrinters, intActivePCCounter
Dim intRowCounter, intColCounter
Dim intProgramCounter, intComputerProgramCount
If IsArray(arrResultsTable) = True Then
Set objExcel = CreateObject("EXCEL.APPLICATION")
objExcel.Visible = True
objExcel.WorkBooks.Add
Set objExcelWorkBook = objExcel.ActiveWorkbook
objExcelWorkBook.Activate
objExcel.DisplayAlerts = False
Do While objExcel.Sheets.Count > 1
objExcel.Sheets(1).Delete
Loop
objExcel.DisplayAlerts = True
' *************** All Printers ***************
' objExcel.Sheets(1).Name = "All Printers"
' Display_All_Printers "Excel", objExcel
' ********************************************
' *********** Individual Printers ************
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
objExcel.Sheets(1).Select
objExcel.Sheets.Add
objExcel.Sheets(1).Name = arrActivePCs(intActivePCCounter)
objExcel.Sheets(arrActivePCs(intActivePCCounter)).Move , objExcel.Sheets(objExcel.Sheets.Count)
objExcel.Sheets(arrActivePCs(intActivePCCounter)).Select
Next
objExcel.Sheets(1).Delete
objExcel.ScreenUpdating = False
Show_Computer_Programs objExcel
' ********************************************
objExcel.Sheets(1).Select
objExcel.ActiveSheet.Range("A1").Select
objExcel.ScreenUpdating = True
MsgBox "There were " & objExcel.Sheets.Count & " PCs inspected."
Set objExcelWorkBook = Nothing
Set objExcel = Nothing
Else
MsgBox "No programs have been retrieved. Cannot output to Excel."
End If
End Sub
'*************************************************************
Sub Write_Excel_Header_Row(objExcelApp)
Dim arrFields
Dim intColCounter, strLastColumn
arrFields = Array("Computer", "Owner", "Software", "Version")
For intColCounter = LBound(arrFields) To UBound(arrFields)
objExcelApp.ActiveSheet.Range(Chr(intColCounter + 65) & "1").FormulaR1C1 = arrFields(intColCounter)
Next
strLastColumn = Chr(UBound(arrFields) + 65)
objExcelApp.ActiveSheet.Range("A1:" & strLastColumn & "1").Font.Bold = True
objExcelApp.ActiveSheet.Range("A:" & strLastColumn).EntireColumn.AutoFit
objExcelApp.Cells.Select
objExcelApp.Selection.Sort objExcelApp.ActiveSheet.Range("C2"), 1, , , , , , 1, 1, False, 1
objExcelApp.ActiveSheet.Range("A1").Select
End Sub
'*************************************************************
Sub Show_Computer_Programs(objExcelObj)
Dim intProgramCounter, intComputerProgramCount, intRowCounter, intColCounter, intActivePCCounter
If IsArray(arrResultsTable) = True Then
For intActivePCCounter = LBound(arrActivePCs) To UBound(arrActivePCs)
intComputerProgramCount = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
'MsgBox "Table: " & arrResultsTable(intProgramCounter, 0) & " - ActivePC:" & arrActivePCs(intActivePCCounter)
If arrResultsTable(intProgramCounter, 0) = arrActivePCs(intActivePCCounter) Then
intComputerProgramCount = intComputerProgramCount + 1
End If
Next
ReDim arrComputerPrograms(intComputerProgramCount - 1, UBound(Split(arrResultsRows(0), ";")))
intRowCounter = 0
For intProgramCounter = LBound(arrResultsTable) To UBound(arrResultsTable)
If arrResultsTable(intProgramCounter, 0) = arrActivePCs(intActivePCCounter) Then
For intColCounter = LBound(Split(arrResultsRows(0), ";")) To UBound(Split(arrResultsRows(0), ";"))
arrComputerPrograms(intRowCounter, intColCounter) = arrResultsTable(intProgramCounter, intColCounter)
Next
intRowCounter = intRowCounter + 1
End If
Next
If UBound(arrComputerPrograms) > -1 Then
objExcelObj.Sheets(arrActivePCs(intActivePCCounter)).Select
Display_Single_Computer_Programs objExcelObj
Else
objExcelObj.Sheets(arrActivePCs(intActivePCCounter)).Select
Write_Excel_Header_Row objExcelObj
End If
Next
Else
MsgBox "No programs have been retrieved."
End If
End Sub
'*************************************************************
Sub Display_Single_Computer_Programs(objExcelObj)
Dim intRowCounter, intColCounter
objExcelObj.ActiveSheet.Cells.Select
objExcelObj.Selection.NumberFormat = "@"
For intRowCounter = LBound(arrComputerPrograms) To UBound(arrComputerPrograms)
For intColCounter = LBound(Split(arrResultsRows(0), ";")) To UBound(Split(arrResultsRows(0), ";"))
objExcelObj.ActiveSheet.Range(Chr(intColCounter + 65) & intRowCounter + 2).FormulaR1C1 = arrComputerPrograms(intRowCounter, intColCounter)
If InStr(arrComputerPrograms(intRowCounter, intColCounter), "<Error>") > 0 Then
objExcelObj.ActiveSheet.Range(Chr(intColCounter + 65) & intRowCounter + 2).Select
objExcelObj.Selection.Font.Bold = True
objExcelObj.Selection.Font.ColorIndex = 3
End If
Next
Next
Write_Excel_Header_Row(objExcelObj)
End Sub
'************* PING FUNCTION ********************
Function Ping(ByVal strName)
Dim objFSO, objShell, objTempFile, objTS, strTempFile
Dim strCommand, strReadLine
Dim boolReturn
Set objShell = WScript.CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTempFile = strWorkingDir & "temp.txt"
'Set default return value
boolReturn = False
'Create command line to ping and save results to a temp file
strCommand = "cmd /c ping.exe -n 1 -w 500 " & strName & " > """ & strTempFile & """"
'Execute the command
objShell.Run strCommand, 0, True
'Open the temp text file
Set objTempFile = objFSO.GetFile(strTempFile)
Set objTS = objTempFile.OpenAsTextStream(1)
'Loop through the temp file to see if "reply from" is found,
'if it is then the ping was successful
Do While objTs.AtEndOfStream <> True
strReadLine = objTs.ReadLine
If InStr(LCase(strReadLine), "reply from") > 0 Then
boolReturn = True
Exit Do
End If
Loop
'Close temp file and release objects
objTS.Close
objTempFile.Delete True
Set objTS = Nothing
Set objTempFile = Nothing
Set objShell = Nothing
Set objFSO = Nothing
'Return value
Ping = boolReturn
End Function
'===================
Thanks Rob any help with the related post....
Rob even now i get this
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Any ideas....
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Any ideas....
Rob even now i get this
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Any ideas....
--------------------------
Windows Script Host
--------------------------
Script: C:\Software.vbs
Line: 66
Char: 13
Error: Permission denied: 'GetObject'
Code: 800A0046
Source: Microsoft VBScript runtime error
--------------------------
OK
--------------------------
Any ideas....
Rob i even saw in some cases the scan suceeds say i have 50 machine names in the txt file. And it says 46 inspected but the 4 that was not scanned there names do not come in the results file...
Thanks Rob, this updated code works perfect
:^)
I have some suggestions for DOS based ideas, but I am sure someone with good VB scripting wil have a much prettier output.....