Re: Win32_Product doesn't list all installed Applications

Thanks for your help! I incorporated a part of your remote script into mine
and it works! But it will duplicate some entries more than once. What do you
think? Thanks!
--
Manlytrash

'**********************************************
'Date: 05/30/2005
'Title: SMS-PC-Software-Inventory.vbs
'Version: 1.03
'Authors: Clark Caldwell/Torgeir Bakken
'Use: Create network computer software inventory in an Excel Spread***.
'Comments:
'Must have ADSI and WMI installed on PC running script.
'
'Must have Excel!
'
'Must have Admin rights on machines you connect to.
'
'If a computer cannot be contacted then it will write that IP to
'PC_Inv_NA.txt outputfile.
'
'Windows XP SP 2 firewall will block this script, enable file/print
'sharing and Remote Administration manualy or through a GPO.
'
'Must create the PC_Inv_IP.txt file with the provided script or
'manualy with IP addresses.
'
'Email ccaldwell@xxxxxxxxxx with problems/sugestions.
'
'***** DECLARATIONS*****************************
CONST ForReading = 1
CONST ForWriting = 2
CONST DEV_ID = 0
CONST FSYS = 1
CONST DSIZE = 2
CONST FSPACE = 3
CONST USPACE = 4
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
CONST TITLE = "SMS-PC-Software-Inventory"

Dim fso, f, fsox, fx, objXL, wmiPath, strNoPing
Dim computerIndex, wscr, adsi, intbutton, strStart, Cshell, strNoConnect
Dim inputFile, outputFile, objKill, strAction, strComplete
Dim strPC, intRow, strFilter, RowNum, strSKUNumber, strVendor, strVersion,
strSD
Dim strUser, strHostName, strCaption, strDescription, strInstallDate
DIM strInstallLocation, strSoftwareName, strPackageCache
Dim pathlength, Scriptpath, objIEScan, oRegistry, iRC

'Get Script Location
pathlength = Len(WScript.ScriptFullName) - Len(WScript.ScriptName)
Scriptpath = Mid(WScript.ScriptFullName, 1, pathlength)

set adsi = CreateObject("ADSystemInfo")
set wscr = CreateObject("WScript.Network")

inputFile = "PC_Inv_IP.txt" 'List of IP's to scan.
outputFile = "PC_Inv_NA.txt" 'List of IP's that couldn't be scanned.

Call KillFile()

set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.OpenTextFile(inputFile, ForReading, True)
set fsox = CreateObject("Scripting.FileSystemObject")
set fx = fsox.OpenTextFile(outputFile, ForWriting, True)
Set Cshell = CreateObject("WScript.Shell")
computerIndex = 1

'*****[ FUNCTIONS ]*******************************

Function Ask(strAction)
intButton = MsgBox(strAction, vbQuestion + vbYesNo, TITLE)
Ask = intButton = vbNo
End Function

'*****[ MAIN SCRIPT ]*****************************

If Ask("Run Network Software Inventory?") Then
Wscript.Quit
Else
strStart = "Inventory run started: " & Date & " at " & time
End If

Call BuildXLS()
Call Connect()
Call Footer()

objIEScan.Quit

objXL.ActiveWorkbook.SaveAs Scriptpath & "SMS-Network-Software-Inventory.xls":
MsgBox "Your inventory run has completed!", vbInformation + vbOKOnly, TITLE

'*** Subroutine Connect ***

Sub Connect()

Do While f.AtEndOfLine <> True
strPC = f.ReadLine
If strPC <> "" Then
If Not IsConnectible(strpc, "", "") Then

strNoPing = "Couldn't ping " & strPC
Call MsgNoPing()
Call Error()
Else
On Error Resume Next
set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!//" &
strPC & "/root/cimv2")

If Err.Number <> 0 Then

strNoConnect = "Couldn't connect to " & strPC
Call MsgNoConnect()
Call Error()
Else

strCompName = UCase(strPC)

set HostName = oWMI.ExecQuery("select DNSHostName from
Win32_NetworkAdapterConfiguration where IPEnabled=TRUE")
for each Host in HostName
strHostName = Host.DNSHostName

Next

set loggeduser = oWMI.ExecQuery("select UserName from
Win32_ComputerSystem")
for each logged in loggeduser
struser = logged.UserName
'Start Torgeir Bakken's Remote Registry Script
Next

Set oRegistry =
GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strPC &
"/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
strSoftwareName =
InstalledApplications & sValue
End If
'End Torgeir Bakken's Remote
Registry Script
Call AddLineToXLS(strHostName, struser, strSoftwareName)

Next
End If
End If
End If
Loop

End Sub


'*** Subroutine Build XLS ***

Sub BuildXLS()

intRow = 1
Set objXL = Wscript.CreateObject("Excel.Application")
objXL.Visible = True
objXL.WorkBooks.Add
objXL.Sheets("Sheet1").Select()
objXL.Sheets("Sheet1").Name = "Software Inventory"

'** Set Row Height
objXL.Rows(1).RowHeight = 15

'** Set Column widths
objXL.Columns(1).ColumnWidth = 11
objXL.Columns(2).ColumnWidth = 15
objXL.Columns(3).ColumnWidth = 50

'*** Set Cell Format for Column Titles ***

objXL.Range("A1:C1").Select
objXL.Selection.Font.Bold = True
objXL.Selection.Font.Size = 8
objXL.Selection.Interior.ColorIndex = 11
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 2
objXL.Selection.WrapText = True
objXL.Columns("A:C").Select
objXL.Selection.HorizontalAlignment = 3 'xlCenter

'*** Set Column Titles ***

Call AddLineToXLS("HostName","Logged on User","Software Name")

Set objIESmoke = WScript.CreateObject("InternetExplorer.Application")
objIESmoke.Navigate("about:blank")
objIESmoke.ToolBar = 0
objIESmoke.StatusBar = 0
objIESmoke.Width= 200
objIESmoke.Height = 100
objIESmoke.Left = 400
objIESmoke.Top = 400
Set objDoc = objIESmoke.Document.Body
strHTML = "Smoke'm if you Got'em"
objDoc.InnerHTML = strHTML
objIESmoke.Visible = True
WScript.Sleep 2700
objIESmoke.Quit

Set objIEScan = WScript.CreateObject("InternetExplorer.Application")
objIEScan.Navigate("about:blank")
objIEScan.ToolBar = 0
objIEScan.StatusBar = 0
objIEScan.Width = 200
objIEScan.Height = 100
objIEScan.Left = 400
objIEScan.Top = 400
Set objDoc = objIEScan.Document.Body
strHTML = "Scanning..."
objDoc.InnerHTML = strHTML
objIEScan.Visible = True

End Sub

'*** Subroutine Add Lines to XLS ***

objXL.Columns("A:C").Select
objXL.Selection.HorizontalAlignment = 3 'xlCenter
objXL.Selection.Font.Size = 8

Sub AddLineToXLS(strHostName, struser, strSoftwareName)

objXL.Cells(intRow, 1).Value = strHostName
objXL.Cells(intRow, 2).Value = struser
objXL.Cells(intRow, 3).Value = strSoftwareName
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Sub

objXL.Columns("A:C").Select
objXL.Selection.HorizontalAlignment = 2 'xlRight
objXL.Selection.Font.Size = 8

'*** Delete file if exists ***

Sub KillFile()

Set objKill = CreateObject("Scripting.FileSystemObject")
If (objKill.FileExists("PC_Inv_NA.txt")) Then
objKill.DeleteFile("PC_Inv_NA.txt")
End If
Set objKill = Nothing
End Sub

'*** Sub to add footer when spead*** is complete ***

Sub Footer()

strFooter1 = "DBlair Ltd. Computer Services"
strFooter2 = "Script Created by Clark Caldwell for Software Inventory"
strComplete = "Inventory run completed at: " & Date & " at " & time

intRow = intRow + 2

'** Set Cell Format for Row

objXL.Cells(intRow, 2).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlRight
objXL.Cells(intRow, 2).Value = strFooter1

intRow = intRow + 1

'** Set Cell Format for Row

objXL.Cells(intRow, 2).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlRight
objXL.Cells(intRow, 2).Value = strFooter2

intRow = intRow + 1

'** Set Cell Format for Row

objXL.Cells(intRow, 2).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlRight
objXL.Cells(intRow, 2).Value = strStart

intRow = intRow + 1

'** Set Cell Format for Row

objXL.Cells(intRow, 2).Select
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.Font.Size = 8
objXL.Selection.Font.Bold = False
objXL.Selection.HorizontalAlignment = 2 'xlRight
objXL.Cells(intRow, 2).Value = strComplete

intRow = intRow + 1

End Sub

'*** ErrorHandler ***

Sub Error()

fx.WriteLine(strPC)

End Sub

'*** Ping Host Timeout ***

Function IsConnectible(sHost, iPings, iTO)
' Returns True or False based on the output from ping.exe
'
' Author: Alex Angelopoulos/Torgeir Bakken
' Works an "all" WSH versions
' sHost is a hostname or IP
' iPings is number of ping attempts
' iTO is timeout in milliseconds
' if values are set to "", then defaults below used


Const OpenAsASCII = 0
Const FailIfNotExist = 0
Const ForReading = 1
Dim oShell, oFSO, sTempFile, fFile

If iPings = "" Then iPings = 2
If iTO = "" Then iTO = 750

Set oShell = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")

sTempFile = oFSO.GetSpecialFolder(2).ShortPath & "\" & oFSO.GetTempName

oShell.Run "%comspec% /c ping.exe -n " & iPings & " -w " & iTO & " " &
sHost & ">" & sTempFile, 0 , True
Set fFile = oFSO.OpenTextFile(sTempFile, ForReading, FailIfNotExist,
OpenAsASCII)

Select Case InStr(fFile.ReadAll, "TTL=")
Case 0 IsConnectible = False
Case Else IsConnectible = True
End Select

fFile.Close
oFSO.DeleteFile(sTempFile)

End Function

Sub MsgNoPing()

Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate("about:blank")
objIE.ToolBar = 0
objIE.StatusBar = 0
objIE.Width= 200
objIE.Height = 100
objIE.Left = 400
objIE.Top = 400
Set objDoc = objIE.Document.Body
strHTML = strNoPing
objDoc.InnerHTML = strHTML
objIE.Visible = True
WScript.Sleep 2500
objIE.Quit

End Sub

Sub MsgNoConnect()

Set objIE2 = WScript.CreateObject("InternetExplorer.Application")
objIE2.Navigate("about:blank")
objIE2.ToolBar = 0
objIE2.StatusBar = 0
objIE2.Width= 200
objIE2.Height = 100
objIE2.Left = 400
objIE2.Top = 400
Set objDoc = objIE2.Document.Body
strHTML = strNoConnect
objDoc.InnerHTML = strHTML
objIE2.Visible = True
WScript.Sleep 2500
objIE2.Quit

End Sub


.