Solved

VBScript Required. Script to query registry on all PCs in Domain and report back all installed software.

Posted on 2009-05-06
13
1,601 Views
Last Modified: 2012-05-06
Hello Experts,

Iam in urgent need of a VBScript that can query registry on all computers in the domain and then report back the following in a .csv or which ever is the best way to record such large amount of data. If we can also include the ability to choose the OUs as an option that would be great.

I am looking at other scripts from Rob but it looks like it doesnt suit my requirements..

example. "Domain Inventory.csv"

Column1              Column2
Computer name: %name%
Logged user: %username%
Installed Apps: %Apps%

Happy to provide more info.
0
Comment
Question by:vithal_m
  • 8
  • 5
13 Comments
 
LVL 12

Expert Comment

by:zoofan
ID: 24321408
I wrote this one about a year ago, does do what you need?

grabs all apps listed in uninstall key from the registry(basically everything in add/remove)
is feed from a txt file list of pc names.
and outputs to a csv file.

http://www.experts-exchange.com/OS/Microsoft_Operating_Systems/Q_22735065.html




zf
0
 
LVL 12

Expert Comment

by:zoofan
ID: 24321410
The code.





zf
'===Start copy: getapps.vbs===
' ---------------------------------------------------------------'
' getappversions.vbs
' 'Sample VBScript to query remote computers
' 'and return versions for word and excel.
' ''Author Riley C. aka ZooFan
' '''Version 2.9 - August 2007
' ''''www.experts-exchange.com question ID: 22735065
' ---------------------------------------------------------------'
'
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 3 'FileObject Access Type
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 'FileObject Format Type
Dim objFso
Dim objWshshell
Dim objOutputFile
Dim strCurPath
Dim dte
Dim tme
Dim arrPCnames()
Dim intPCLoop      
Dim strNewFile
Dim strPCFile
Dim objPCOutputFile
      Set objFso = CreateObject("Scripting.FileSystemObject")
      Set objWshshell = WScript.CreateObject("WScript.Shell")
      strCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
      dte = Replace(FormatDateTime(date(),vbshortdate),"/","-")
      tme = Replace(Replace(FormatDateTime(now(),vbLongtime),":","-")," ","")
      strNewFile = strCurPath & "\" & tme & "_" & dte & ".csv"
      strPCFile = InputBox("Please enter the full path and file" & VbCrLf & "name of the file with the computer names.","Get application versions from remote computers..")
            If Not objFso.FileExists(strPCFile) Then
                  MsgBox "You must enter a valid full path and file name!",vbOKOnly,"Get application versions from remote computers.."
                WScript.Quit(0)
            Elseif strPCFile = "" Then
                  MsgBox "You must enter a filename!",vbOKOnly,"Get application versions from remote computers.."
                WScript.Quit(0)
            Else
            Call createoutputfile(strNewFile)
            Call readpclist(strPCFile)
            Set objOutputFile = objFso.OpenTextFile(strNewFile,ForWriting,TristateUseDefault)
                  objOutputFile.WriteLine("Computer,Apps List")
                                                 For intPCLoop = LBound(arrPCnames) To UBound(arrPCnames)
                                                objOutputFile.WriteLine(arrPCnames(intPCLoop) & "," & InstalledApps(arrPCnames(intPCLoop)))
                                                Next
                              objOutputFile.Close                                                
                  MsgBox "File has been processed, and results saved in " & strNewFile ,vbOKOnly,"Get application versions from remote computers."      
            End If
      WScript.Quit(0)                                    
Sub readpclist(strPcList)
Dim objPCnames
Dim objReadFile
Dim intLneCount
      Set objPCnames = objFso.GetFile(strPCFile)
      Set objReadFile = objPCnames.OpenAsTextStream(ForReading, TristateUseDefault)
            Do Until objReadFile.AtEndOfStream
                  ReDim Preserve arrPCnames(intLneCount)
                  arrPCnames(intLneCount) = objReadFile.ReadLine
                  intLneCount = intLneCount + 1
            Loop
      objReadFile.Close
End sub                                    
Sub createoutputfile(strNewFileName)
            If objFso.FileExists(strNewFileName) Then
                  objFso.deleteFile(strNewFileName)
            Else
                  Set objOutputFile = objFso.CreateTextFile(strNewFileName)
                  objOutputFile.Close      
            End If
End Sub
Function InstalledApps(strPcName)
Dim appsFile
Dim strRegValue
Dim strKey
Dim intRegTest
Dim strBaseKey
Dim arSubKeys()
Dim strValue
Dim iErr
Dim iErr2
Dim testConn
Dim errMess
 Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
 On Error Resume Next
      Set testConn = GetObject("winmgmts:\\" & strPcName,"Root\CIMV2")
      iErr = Hex(Err.Number)
      Select Case Ucase(iErr)
          Case "1AD"
                         Set strRegValue = GetObject("winmgmts://" & strPcName & "/root/default:StdRegProv")
                         iErr2 = Hex(Err.Number)
                               Select Case Ucase(iErr2)
                                     Case "1AD"
                                           strBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
                                           intRegTest = strRegValue.EnumKey(HKLM, strBaseKey, arSubKeys)
                                          For Each strKey In arSubKeys
                                                intRegTest = strRegValue.GetStringValue(HKLM, strBaseKey & strKey, "DisplayName", strValue)
                                                      If intRegTest <> 0 Then
                                                            strRegValue.GetStringValue HKLM, strBaseKey & strKey, "QuietDisplayName", strValue
                                                      End If
                                                      If strValue <> "" Then
                                                            InstalledApps = InstalledApps & strValue & ","
                                                      End If
                                          Next
                                    Case Else
                                          InstalledApps = Err.Description      
                              End Select
                  Case Else
                        InstalledApps = Err.Description
            End Select
 
End Function
'===End copy: getapps.vbs===

Open in new window

0
 
LVL 12

Expert Comment

by:zoofan
ID: 24321415
would be happy to modify it to better suit if need be.



zf
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:vithal_m
ID: 24321423
Hello Zoofan,

Thanks for the quick reply.

does this code grab only Windows Installer based apps or all installed apps?

thanks,
VM
0
 
LVL 12

Expert Comment

by:zoofan
ID: 24321434
Grabs all apps listed/registered in

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall

so both.


zf
0
 
LVL 12

Accepted Solution

by:
zoofan earned 500 total points
ID: 24321517
Here is a modified version so you can do it by OU,

edit line 27 to the OU path you wish to run against(does a recursive search to include sub ou's)

Output file is csv to same directory the script is run from.


zf
'===Start copy: getapps.vbs===
' ---------------------------------------------------------------'
' getapps.vbs
' 'Sample VBScript to query remote computers
' 'for list of installed apps
' ''Author Riley C. aka ZooFan
' '''Version 3.0 - May 2009
' ''http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_24387274.html#a24321434
' ---------------------------------------------------------------'
'
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 3 'FileObject Access Type
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0 'FileObject Format Type
Dim objFso
Dim objWshshell
Dim objOutputFile
Dim strCurPath
Dim dte
Dim tme
Dim strNewFile
Dim arrPCnames()
Dim intPCLoop      
Dim objPCOutputFile
Dim strOUpath
 
'Edit To OU path To start does a recussive search
strOUpath = "OU=computers,DC=domain,DC=com"
 
      Set objFso = CreateObject("Scripting.FileSystemObject")
      Set objWshshell = WScript.CreateObject("WScript.Shell")
      strCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
      dte = Replace(FormatDateTime(date(),vbshortdate),"/","-")
      tme = Replace(Replace(FormatDateTime(now(),vbLongtime),":","-")," ","")
      strNewFile = strCurPath & "\" & tme & "_" & dte & ".csv"
     
            Call createoutputfile(strNewFile)
            Call createpclist(strOUpath,arrPCnames)
            Set objOutputFile = objFso.OpenTextFile(strNewFile,ForWriting,TristateUseDefault)
                  objOutputFile.WriteLine("Computer,Apps List")
                                                 For intPCLoop = LBound(arrPCnames) To UBound(arrPCnames)
                                                objOutputFile.WriteLine(arrPCnames(intPCLoop) & "," & InstalledApps(arrPCnames(intPCLoop)))
                                                Next
                              objOutputFile.Close                                                
                  MsgBox "File has been processed, and results saved in " & strNewFile ,vbOKOnly,"Get application versions from remote computers."      
       
      WScript.Quit(0)                                    
                                  
Sub createoutputfile(strNewFileName)
            If objFso.FileExists(strNewFileName) Then
                  objFso.deleteFile(strNewFileName)
            Else
                  Set objOutputFile = objFso.CreateTextFile(strNewFileName)
                  objOutputFile.Close      
            End If
End Sub
Function InstalledApps(strPcName)
Dim appsFile
Dim strRegValue
Dim strKey
Dim intRegTest
Dim strBaseKey
Dim arSubKeys()
Dim strValue
Dim iErr
Dim iErr2
Dim testConn
Dim errMess
 Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
 On Error Resume Next
      Set testConn = GetObject("winmgmts:\\" & strPcName,"Root\CIMV2")
      iErr = Hex(Err.Number)
      Select Case Ucase(iErr)
          Case "1AD"
                         Set strRegValue = GetObject("winmgmts://" & strPcName & "/root/default:StdRegProv")
                         iErr2 = Hex(Err.Number)
                               Select Case Ucase(iErr2)
                                     Case "1AD"
                                           strBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
                                           intRegTest = strRegValue.EnumKey(HKLM, strBaseKey, arSubKeys)
                                          For Each strKey In arSubKeys
                                                intRegTest = strRegValue.GetStringValue(HKLM, strBaseKey & strKey, "DisplayName", strValue)
                                                      If intRegTest <> 0 Then
                                                            strRegValue.GetStringValue HKLM, strBaseKey & strKey, "QuietDisplayName", strValue
                                                      End If
                                                      If strValue <> "" Then
                                                            InstalledApps = InstalledApps & strValue & ","
                                                      End If
                                          Next
                                    Case Else
                                          InstalledApps = Err.Description      
                              End Select
                  Case Else
                        InstalledApps = Err.Description
            End Select
 
End Function
 
Function createPClist(strOUstart,arrName)
	Const ADS_SCOPE_SUBTREE = 2  
 	Dim strCommon  
 	Dim i,j
 	Set strCommon = CreateObject("ADODB.Connection")  
 	strCommon.Provider = "ADsDSOObject" 
 	strCommon.Open "Active Directory Provider" 
 	Dim strQueryString  
 	Set strQueryString = CreateObject("ADODB.Command")  
 	Set strQueryString.ActiveConnection = strCommon   
 	strQueryString.CommandText =  "SELECT name " & _  
 	                  "FROM 'LDAP://" & strOUstart & "' " & _  
 	                  "WHERE objectClass='computer' " & _  
 	                  "ORDER BY name"
 	strQueryString.Properties("Page Size") = 1000  
 	strQueryString.Properties("Searchscope") = ADS_SCOPE_SUBTREE  
 	 
 	Dim  strReturn  
 	Set strReturn = strQueryString.Execute  
 	strReturn.MoveFirst  
 	i = 0
 	j = 1
 	ReDim arrname(j)
 	Do Until strReturn.EOF  
 		
 	  arrName(i) = strReturn(0)  
 	  i = i + 1
 	  j = i + 1
 	  ReDim Preserve arrName(j)
 	  strReturn.MoveNext  
 	Loop
End Function
 
'===End copy: getapps.vbs===

Open in new window

0
 

Author Comment

by:vithal_m
ID: 24321616
thanks for the reply.

I would like to exclude Hotfixes from this list. is it possible?

thanks,VM
0
 
LVL 12

Expert Comment

by:zoofan
ID: 24321648
As there is no common key(element) that will cover ALL hot fixes, about the only thing I could do for that would be to exclude everything that starts with KB(knowledge Base) XXXXXXX from the list.

zf
0
 

Author Comment

by:vithal_m
ID: 24321669
that would be great.and also sorry for doing this..can we have some check as an option and exclude servers from the list. just add a pop up button after i input the computers list files. do you wan to exclude server yes or no.

I know that you can use this
ProductType from ("Win32_OperatingSystem") and check if its a server. If ProductType =1 it is a server. it anything else is a workstation or laptop etc..

Thanks heaps.
VM.
0
 

Author Comment

by:vithal_m
ID: 24321842
I ran the above script and got the following message for the first 70 machines
"The remote server machine does not exist or is unavailable"
I have manually pinged the machines and they respond. Remote registry is enabled.


0
 
LVL 12

Assisted Solution

by:zoofan
zoofan earned 500 total points
ID: 24322255
make sure WMI is running and functioning correctly as well, the connection goes in thru WMI.  also requires admin account,  firewall rules can also block WMI requests.

you can test the wmi connection with the script below if you want.
edit line 5 to test a diffent computer.

zf
Option Explicit
 
On Error Resume Next
 
Const DEFAULT_COMPUTER  = "localhost"
Const DEFAULT_NAMESPACE = "root\cimv2"
 
Dim objLoc
Dim objWmi
Dim strSysname
Dim strNamespace
Dim strUsername
Dim strPassword
Dim blnQuiet
 
strSysname   = DEFAULT_COMPUTER
strNamespace = DEFAULT_NAMESPACE
strUsername  = ""
strPassword  = ""
blnQuiet     = False
If fctIsAlive(strSysname) Then
 If Not blnQuiet Then
  WScript.Echo "ICMP Ping for " & strSysname & " passed."
  WScript.Echo "Connecting to namespace " & strNamespace & " . . ."
 End If
 Set objLoc = WScript.CreateObject("WbemScripting.SWbemLocator")
 Set objWmi = objLoc.ConnectServer(strSysname, strNamespace, strUsername, strPassword)
 If Err.Number Then
  If Not blnQuiet Then
   WScript.Echo "Unable to connect to WMI: " & Err.Description
  End If
  Err.Clear
  WScript.Quit(2)
 Else
  Set objWmi = Nothing
  Set objLoc = Nothing
  If Not blnQuiet Then
   WScript.Echo "WMI successfully connected."
  End If
  WScript.Quit(0)
 End If
Else
 If Not blnQuiet Then
  WScript.Echo "ICMP Ping for " & strSysname & " failed."
 End If
 WScript.Quit(1)
End If
 
Function fctIsAlive(strHostOrIP)
 
Dim objSh, objCmd, strCmd
 
strCmd     = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 " & strHostOrIP & " | " _
           & "%SystemRoot%\system32\find.exe /c /i " & Chr(34) & "ttl=" & Chr(34)
Set objSh  = WScript.CreateObject("WScript.Shell")
Set objCmd = objSh.Exec(strCmd)
fctIsAlive = CBool(Trim(objCmd.StdOut.ReadAll))
Set objCmd = Nothing
Set objSh  = Nothing
 
End Function

Open in new window

0
 

Author Comment

by:vithal_m
ID: 24322295
I was searching on google for something and bumped into this...this script works but the formatting is totally out. This does not have the WMI issue. and WMI is turned on all PCs by default.

' This code developed by Timothy Brigham July 2006.
' Revisions made Oct 2007

' This is designed to be run by an administrator to audit the software installed
' throughout a domain. You will need to adjust the LDAP query to reflect your local
' configuration. You may additionally define OUs to restrict and speed up the search.

' Much of this code collected from various usenet sources.

' Revision 2 - includes logging to a text file

' This is Tim Brigham. Revision 2 of my software audit software is available now,
' including logging to a text file. The default path for the saved audit is
' C:\TimSoftwareAudit.txt, but can be edited by changing the path below.

' Please note that the oContainer item with the LDAP query does not
' need to point to the root of the domain. I use this script frequently
' on specific OUs. The easiest way to do determine the LDAP syntax is to use an
' LDAP browser, such as adsiedit from Microsoft. Simply copy and paste in
' the distinguishedName attribute.

' If you have any questions, please comtact me at timbrigham@gmail.com.

Set fso = CreateObject("Scripting.FileSystemObject")

' **************************************************
' make any changes here to set properties of the audit


Set oContainer=GetObject("LDAP://DC=au,DC=challenger,DC=net")
Set LogFile = fso.CreateTextFile("C:\TimSoftwareAudit.csv", True)

' no changes should be needed under this point
' **************************************************


Dim oContainer

ListComputers oContainer
Set oContainer = Nothing

Sub ListComputers(oObject)
Dim Object
For Each Object in oObject
  If Object.Class = "organizationalUnit" Then
    ListComputers ( Object )
  End If

  If Object.Class = "computer" Then
    Name = Object.Name
    Name = Mid( Name, 4 )

    'WScript.Echo "Computer Name: "
    'WScript.Echo Name

    LogFile.WriteLine("Computer Name:,"+Name)
   ' LogFile.WriteLine(Name)

    On Error Resume Next

    'WScript.Echo "Logged in User(s): "
    UserName = GetUser(Name)
   ' WScript.Echo UserName
    LogFile.WriteLine("Logged in User(s):,"+UserName)
    'LogFile.WriteLine(UserName)


    'WScript.Echo "Installed Applications: " 
    Installed = InstalledApplications(Name)
    'WScript.Echo Installed
    'WScript.Echo ""
    'WScript.Echo ""
    LogFile.WriteLine "Installed Applications"
      LogFile.WriteLine(","+Installed)
   ' LogFile.WriteLine("")
    LogFile.WriteLine("")


  End If
Next

End Sub

Function GetUser( strComputer )
  Set objWMIService = GetObject("winmgmts:" _
      & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
  Set colComputer = objWMIService.ExecQuery _
      ("Select * from Win32_ComputerSystem")
  For Each objComputer in colComputer
      GetUser = GetUser & objComputer.UserName & vblf
  Next
End Function

Function InstalledApplications(node)
 Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
 Set oRegistry = _
  GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
  & node & "/root/default:StdRegProv")
 sBaseKey = _
  "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
 iRC = oRegistry.EnumKey(HKLM, sBaseKey, arSubKeys)
 For Each sKey In arSubKeys
  iRC = oRegistry.GetStringValue( _
   HKLM, sBaseKey & sKey, "DisplayName", sValue)
  If iRC <> 0 Then
   oRegistry.GetStringValue _
    HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
  End If
  If sValue <> "" Then
   InstalledApplications = _
    InstalledApplications & sValue & vbCrLf
  End If
 Next
End Function
0
 
LVL 12

Expert Comment

by:zoofan
ID: 24326938
Looks to also use WMI


zf
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Welcome, welcome!  If you are new to the series and haven't been following along, please take a brief moment to review the first three installments: Part 1 (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/A_266-VBScri…
Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
How to Install VMware Tools in Red Hat Enterprise Linux 6.4 (RHEL 6.4) Step-by-Step Tutorial
Exchange organizations may use the Journaling Agent of the Transport Service to archive messages going through Exchange. However, if the Transport Service is integrated with some email content management application (such as an antispam), the admini…

680 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question