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
LVL 1
SeanAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

johnb6767Commented:
Rob, you have an audience too.....

:^)

I have some suggestions for DOS based ideas, but I am sure someone with good VB scripting wil have a much prettier output.....
0
greymirrorCommented:
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 :)
0
RobSampsonCommented:
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\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
            Set objWMIService = GetObject("winmgmts:" _
                & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
            
            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
            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
'===================

Regards,

Rob.
0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

greymirrorCommented:
Hats off, Rob :) You *are* a genius!

RE PSTools, i meant psInfo (which was what the link was). My bad for not saying that
0
RobSampsonCommented:
Cool.  Thanks for the info......cheers for the compliment.....

Rob.
0
SeanAuthor Commented:
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.Shell")
Set WSHProcess = WSHShell.Environment("Process")
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.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colComputerIP = objWMIService.ExecQuery _
    ("Select * from Win32_NetworkAdapterConfiguration")
 
For Each IPConfig in colComputerIP
      If Not IsNull(IPConfig.IPAddress) Then
        For intIPCount = LBound(IPConfig.IPAddress) To UBound(IPConfig.IPAddress)
                strIPAddress = strIPAddress & "IP Address: " & IPConfig.IPAddress(intIPCount) & "~"
            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(intLineCount) & VbCrLf
                  Next
                  strContents = strContents & arrLinesInFile((intMaxLinesAllowed - 1))
            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(strFullIP, 20, "Right", " ") & "|  " & Pad_String(strHostName, 24, "Right", " ") & "|  " & Now & VbCrLf)
Dim objNetwork, colDrives, strDrives, intDrive
Set objNetwork = CreateObject("WScript.Network")
Set colDrives = objNetwork.EnumNetworkDrives
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(objObjectToCheck, intLevel)
      ' 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("MemberOf")
      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(strOriginalString, intTotalLengthRequired, strDirection, strCharacterToPadWith)
      '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) > 1) Then
            strCharacterToPadWith = Left(strCharacterToPadWith, 1)
      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
'===============
0
RobSampsonCommented:
OK, so here is the same "output to excel" script, only I've changed it to output to CSV for one user only (for a login script), to a text file on your UserLogins share called
strUserName & "_Apps.csv"

I think this would be better to have a separate CSV file for the applications.

The only thing you may want to change in the script is:
boolShowMSKBPatches = vbNo

to vbYes if you want to show KB Patches.

'********************************************************************
' GetSoftwareDetails_On_Login_To_CSV.vbs
'
' 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.
'
' 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.ScriptFullName, WScript.ScriptName, "")

'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.Network")
strComputer = objNetwork.ComputerName
Set objNetwork = Nothing

Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

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\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

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), ";"))
            arrResultsTable(intRowNum, intColNum) = Split(arrResultsRows(intRowNum), ";")(intColNum)
      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.Network")
      Set objFSO = CreateObject("Scripting.FileSystemObject")
      strUserName = objNetwork.UserName
      strCSVPath = "\\corpfs01\UserLogins\" & strUserName & "_Apps.csv"
      Set objCSVFile = objFSO.CreateTextFile(strCSVPath, True)
      
      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(objCSVFile)

      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)
            If intColCounter = 0 Then
                  objCSVFile.Write """" & arrFields(intColCounter) & """"
            Else
                  objCSVFile.Write "," & """" & arrFields(intColCounter) & """"
            End If
      Next

End Sub

'*************************************************************

Sub Show_Computer_Programs(objCSVFile)
      
      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
                        Display_Single_Computer_Programs objCSVFile
                  Else
                        Write_CSV_Header_Row objCSVFile
                  End If
                  
            Next
            
      Else
            'MsgBox "No programs have been retrieved."
      End If
      
End Sub

'*************************************************************

Sub Display_Single_Computer_Programs(objCSVFile)

      Dim intRowCounter, intColCounter

      Write_CSV_Header_Row(objCSVFile)
      
      For intRowCounter = LBound(arrComputerPrograms) To UBound(arrComputerPrograms)
            For intColCounter = LBound(Split(arrResultsRows(0), ";")) To UBound(Split(arrResultsRows(0), ";"))
                  If intColCounter = 0 Then
                        objCSVFile.Write VbCrLf & """" & arrComputerPrograms(intRowCounter, intColCounter) & """"
                  Else
                        objCSVFile.Write "," & """" & arrComputerPrograms(intRowCounter, intColCounter) & """"
                  End If
            Next
      Next
      
End Sub
'********************************************************************


And then, to have your existing logon script run this when it's finished, above this line:
Sub GetMemberOfNames(objObjectToCheck, intLevel)

put this:
Dim strGetAppsVBSPath
strGetAppsVBSPath = "\\domain.com\sysvol\domain.com\scripts\GetSoftwareDetails_On_Login_To_CSV.vbs"
objShell.Run "wscript """ & strGetAppsVBSPath & """", 1, False

and change the domain.com bits to your domain name.

Regards,

Rob.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SeanAuthor Commented:
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

0
RobSampsonCommented:
But appending could get very large very quickly.......are you sure?  If so, just change this:
Set objCSVFile = objFSO.CreateTextFile(strCSVPath, True)

to this:
Set objCSVFile = objFSO.OpenTextFile(strCSVPath, 8, True)

Regards,

Rob.
0
SeanAuthor Commented:
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
0
RobSampsonCommented:
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.
0
RobSampsonCommented:
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_Login_To_CSV.vbs
'
' 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.
'
' 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.ScriptFullName, WScript.ScriptName, "")

'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.Network")
strComputer = objNetwork.ComputerName
Set objNetwork = Nothing

Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

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\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

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), ";"))
            arrResultsTable(intRowNum, intColNum) = Split(arrResultsRows(intRowNum), ";")(intColNum)
      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.Network")
      Set objFSO = CreateObject("Scripting.FileSystemObject")
      strUserName = objNetwork.UserName
      strCSVPath = "\\corpfs01\UserLogins\" & strUserName & "_Apps.csv"
      strCSVPath = "\\ntfp\userlogins$\" & strUserName & "_Apps.csv"
      'Set objCSVFile = objFSO.CreateTextFile(strCSVPath, True)
      Set objCSVFile = objFSO.OpenTextFile(strCSVPath, 8, True)
      
      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(objCSVFile)

      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)
            If intColCounter = 0 Then
                  objCSVFile.Write """" & arrFields(intColCounter) & """"
            Else
                  objCSVFile.Write "," & """" & arrFields(intColCounter) & """"
            End If
      Next

End Sub

'*************************************************************

Sub Show_Computer_Programs(objCSVFile)
      
      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
                        objCSVFile.Write """Date"",""" & Date & """,""Time"",""" & Time & """" & vbCrLf
                        Display_Single_Computer_Programs objCSVFile
                  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_Programs(objCSVFile)

      Dim intRowCounter, intColCounter

      Write_CSV_Header_Row(objCSVFile)
      
      For intRowCounter = LBound(arrComputerPrograms) To UBound(arrComputerPrograms)
            For intColCounter = LBound(Split(arrResultsRows(0), ";")) To UBound(Split(arrResultsRows(0), ";"))
                  If intColCounter = 0 Then
                        objCSVFile.Write VbCrLf & """" & arrComputerPrograms(intRowCounter, intColCounter) & """"
                  Else
                        objCSVFile.Write "," & """" & arrComputerPrograms(intRowCounter, intColCounter) & """"
                  End If
            Next
      Next
      
End Sub




Regards,

Rob.
0
blahblah777Commented:
I have a thread http://www.experts-exchange.com/Software/Server_Software/File_Servers/Active_Directory/Q_24028067.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?
0
RobSampsonCommented:
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.
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"

Open in new window

0
RobSampsonCommented:
Or, to get a list of computers from a specific OU only, you can use this.

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"

Open in new window

0
blahblah777Commented:
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
0
RobSampsonCommented:
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.
0
SeanAuthor Commented:
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
0
RobSampsonCommented:
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.
0
bsharathCommented:
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.
0
bsharathCommented:
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.
0
RobSampsonCommented:
Which version are you using, and what line is the error on?

Rob.
0
bsharathCommented:
Hi Rob i am using this version
ID: 20838080
0
bsharathCommented:
Hi Rob i am using this version
ID: 20838080
0
RobSampsonCommented:
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.
0
blahblah777Commented:
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
0
bsharathCommented:
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...
http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_24054393.html
This to ease the running on a lot of machines....
0
RobSampsonCommented:
Hi guys, you're right....there was no error checking on line 66.....it is now treated as an inactive PC.

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
'===================

Open in new window

0
bsharathCommented:
Thanks Rob any help with the related post....
0
bsharathCommented:
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....
0
bsharathCommented:
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....
0
bsharathCommented:
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...
0
blahblah777Commented:
Thanks Rob, this updated code works perfect
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.