Lister les applications installées

Option Explicit

Dim strComputer
Dim ListeMachines, TableauListeMachines
Dim CheminScriptActuel, CheminFichierResultat, ScriptFileName, Position, objFSO, objFichierResultat
Dim strKey, strEntry1a, strEntry1b, strEntry6, strEntry2, strEntry3, strEntry4, strEntry5
Dim objReg, arrSubkeys, strSubkey, strValue1, strValue2, strValue3, strValue4, strValue5, strValue6, intValue1, intValue2, intValue3, intValue4, intValue5
Dim Result
Dim intRet1

Dim WSHShell, vCOMPUTERNAME

Set WSHShell = CreateObject("WScript.Shell")

vCOMPUTERNAME = WSHShell.ExpandEnvironmentStrings("%COMPUTERNAME%")

ListeMachines = InputBox("Nom de la machine à traiter. Vous pouvez en entrer plusieurs séparées par ;","Nom machine",vCOMPUTERNAME)
'ListeMachines = "." 'Nom de la machine à examiner
'ListeMachines = "NomMachine1;NomMachine2" 'Nom de la machine à examiner


ScriptFileName = wscript.scriptname
Position = InstrRev(ScriptFileName,".")
if (Position > 0) Then ScriptFileName = Left(ScriptFileName, Position - 1)

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierResultat = CheminScriptActuel & "\" & ScriptFileName & "_Resultat.txt"

Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE 
strComputer = "." 
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" 
strEntry1a = "DisplayName"
strEntry1b = "QuietDisplayName"
strEntry6 = "DisplayVersion"
strEntry2 = "InstallDate"
strEntry3 = "VersionMajor"
strEntry4 = "VersionMinor"
strEntry5 = "EstimatedSize"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFichierResultat = objFSO.OpenTextFile(CheminFichierResultat, ForWritting, True)
TableauListeMachines = Split(ListeMachines, ";")

objFichierResultat.WriteLine("ServerName" & VbTab & "Display Name" & VbTab & "Display Version" & VbTab & "Install Date" & VbTab & "VersionMajor" & VbTab & "Version Minor" & VbTab & "Estimated Size")
For Each strComputer in TableauListeMachines

	Err.Clear
	On Error Resume Next
	Set objReg = GetObject("winmgmts://" & strComputer & "/root/default:StdRegProv")
	If Err.Number = 0 Then
		objReg.EnumKey HKLM, strKey, arrSubkeys 
		For Each strSubkey In arrSubkeys

			Result = ""
			intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1) 
			If intRet1 <> 0 Then 
				objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1 
			End If

			If strValue1 <> "" Then 
				'WScript.Echo VbCrLf & "Display Name: " & strValue1
				Result = strComputer
				Result = Result & VbTab & strValue1
				
				objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry6, strValue6
				Result = Result & VbTab & strValue6

				objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
				Result = Result & VbTab & strValue2

				objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry3, intValue3
				objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry4, intValue4
				Result = Result & VbTab & intValue3 & VbTab & intValue4

				objReg.GetDWORDValue HKLM, strKey & strSubkey,strEntry5, intValue5
				If intValue5 <> "" Then
					Result = Result & VbTab & Round(intValue5/1024, 3) & " megabytes"
				Else
					Result = Result & VbTab & ""
				End If

				objFichierResultat.WriteLine(Result)
			End If

		Next

		strKey = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall\"
		objReg.EnumKey HKLM, strKey, arrSubkeys 
		For Each strSubkey In arrSubkeys

			Result = ""
			intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1) 
			If intRet1 <> 0 Then 
				objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1 
			End If

			If strValue1 <> "" Then 
				'WScript.Echo VbCrLf & "Display Name: " & strValue1
				Result = strComputer
				Result = Result & VbTab & strValue1
				
				objReg.GetStringValue HKLM, strKey & strSubkey, strEntry6, strValue6
				Result = Result & VbTab & strValue6

				objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
				Result = Result & VbTab & strValue2

				objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry3, intValue3
				objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry4, intValue4
				Result = Result & VbTab & intValue3 & VbTab & intValue4

				objReg.GetDWORDValue HKLM, strKey & strSubkey,strEntry5, intValue5
				If intValue5 <> "" Then
					Result = Result & VbTab & Round(intValue5/1024, 3) & " megabytes"
				Else
					Result = Result & VbTab & ""
				End If

				objFichierResultat.WriteLine(Result)
			End If

		Next
		Set objReg = Nothing
	
	Else
		Wscript.Echo "Problème pour se connecter à " & strComputer
	End If

Next

objFichierResultat.Close 'Fermeture du fichier
Set objFichierResultat = Nothing

Set objFSO = Nothing
Wscript.Echo "Termine"