'----------------------------------------------------------------------- '--- Capture dans une feuille Excel les logiciels installés --- '--- sur le poste actuel --- '--- --- '--- Nécessite un fichier Excel présent à l'emplacement indiqué --- '--- --- '--- Merci à bbil, Hackoofr - Développez - 06 Juillet 2011 --- '--- Version 0.7 --- '--- Correction du tri - Ajout de "With... End With" --- '--- Changement du format la date de l'opération --- '--- Supression de ".activate" et ".Select" inutiles à dangereux --- '----------------------------------------------------------------------- fctInstalFileInExcelSheet "C:\RecupInstallation.xlsm" '--- END --------------------------------------------------------------- '---------------------------------------------------------------------------- 'Section Fonctions/Procédure '---------------------------------------------------------------------------- Function fctInstalFileInExcelSheet(ByVal FilePath) '--- Déclarations Dim objExcel, objClasseur, oshLstLog 'Classeur Dim strSubkey, arrSubkeys, objReg 'Clé registre Dim strComputer ' Dim sTitle, Rep 'pour MsgBox Dim intRet1 Const xlDown = -4121 'Constante définie Const vbCancel = 2 Dim strNomFeuille strNomFeuille = "Liste logiciels tout poste" 'Nom de la feuille recevant les données par défaut '--- Registre - Paramètre des installations Const HKLM = &H80000002 Const strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" Const strEntry1a = "DisplayName" Const strEntry1b = "QuietDisplayName" Const strEntry2 = "InstallDate" Const strEntry3 = "VersionMajor" Const strEntry4 = "VersionMinor" Const strEntry5 = "EstimatedSize" Dim strValue1, strValue2 Dim intValue3, intValue4, intValue5 '--- Demande confirmation de l'opération qui peut être longue sTitle = "Vous allez rechercher les logiciels installés sur ce poste." & Chr(13) sTitle = sTitle & "Cela peut prendre quelques minutes." & Chr(13) & Chr(13) sTitle = sTitle & "Un message vous avertira de la fin du traitement." Rep = MsgBox(sTitle, vbOKCancel + vbQuestion, "Lancement de la recherche (v0.7)") If Rep = vbCancel Then Exit Function '--- Ouvre session Excel Set objExcel = CreateObject("Excel.Application") On Error Resume Next Set objClasseur = objExcel.Workbooks.Open(FilePath) On Error GoTo 0 If objClasseur Is Nothing Then MsgBox "Le classeur n'est pas au bon endroit ou ne porte pas ce nom (" & FilePath & ")", "Erreur sur ouverture classeur", vbCritical Exit Function End If '--- Paramètrage comportement Excel (à choisir suivant l'effet désiré) objExcel.Application.Visible = False 'Cache Excel objExcel.Application.ScreenUpdating = False 'Ne met pas à jour l'affichage (Inutile ici ?) objExcel.Application.DisplayAlerts = False 'Pas de message d'alerte '--- Choix de la feuille sTitle = "Les données seront placées dans la feuille '" & strNomFeuille & "' du fichier '" & FilePath & "'." sTitle = sTitle & vbCrLf & "Choisissez :" & vbCrLf sTitle = sTitle & " > Oui pour les ajouter à celles existante" & vbCrLf sTitle = sTitle & " > Non, pour les placer dans une nouvelle feuille à la date/heure du moment" & vbCrLf sTitle = sTitle & " > Annuler, pour effacer les données et repartir avec une feuille vierge." Rep = MsgBox(sTitle, vbQuestion + vbYesNoCancel + vbApplicationModal + 256, "CHOIX DE L'EMPLACEMENT DES DONNES RECUEILLIES.") Select Case Rep Case 6, 2 'vbYes, vbCancel 'Procédure normale, ajout à la suite et peut-être en plus efface avant d'ajouter 'Création de la feuille si besoin (supprimée depuis Excel ou fichier neuf) If objExcel.IsError(objExcel.Evaluate("='" & strNomFeuille & "'!A1")) Then ' si erreur => n'existe pas Set oshLstLog = objClasseur.Sheets.Add(, objExcel.Sheets(objExcel.Sheets.Count)) oshLstLog.Name = strNomFeuille Else ' Active la feuille Set oshLstLog = objExcel.Sheets(strNomFeuille) End If 'Distingo entre vbOk(6) et vbCancel (2) If Rep = 2 Then oshLstLog.Range("A:E").Delete Case 7 'vbNo 'Procédure Ajoute une feuille avec la Date/heure actuelle 'Peut propable que l'on ait le même instant donc pas de test strNomFeuille = "Sht_" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "_" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now) Set oshLstLog = objClasseur.Sheets.Add(, objExcel.Sheets(objExcel.Sheets.Count)) oshLstLog.Name = strNomFeuille End Select '--- Mise en page With oshLstLog .Cells(1, 1).Value = "APPLICATIONS INSTALLEES" 'TITRE .Cells(2, 1).Value = "Ordinateurs" ' Entêtes de colonne .Cells(2, 2).Value = "Date de recherche" .Cells(2, 3).Value = "Logiciels" .Cells(2, 4).Value = "Dates d'installation" .Cells(2, 5).Value = "Versions" .Cells(2, 6).Value = "Tailles" .Range("A1:F2").Font.Bold = True '--- Récupération des informations dans le registre strComputer = strGetComputerName If strComputer = vbNullString Then ObjExcel.Quit() Set oshLstLog = Nothing Set objClasseur = Nothing Set objExcel = Nothing Exit Function End If strComputer = Trim(strComputer) If strComputer = "" Then strComputer = "." Set objReg = GetObject("winmgmts://" & strComputer & "/root/default:StdRegProv") objReg.EnumKey HKLM, strKey, arrSubkeys '--- Recherche & Remplissage de la feuille --- For Each strSubkey In arrSubkeys With .Range("A1").End(xlDown).Offset(1, 0) ' Nom de l'ordinateur .Offset(0, 0).Value = strComputer intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1a, strValue1) If intRet1 <> 0 Then objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1b, strValue1 End If ' Date de vérification de l'ordinateur .Offset(0, 1).Value = FormatDateTime(Now, vbShortDate) 'vbGeneralDate vbLongDate vbShortDate vbLongTime vbShortTime ' Nom du programme installé If strValue1 <> "" Then .Offset(0, 2).Value = strValue1 End If ' Date d'installation objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2 If strValue2 <> "" Then .Offset(0, 3).Value = Left(strValue2, 4) & "/" & Mid(strValue2, 4, 2) & "/" & Right(strValue2, 2) End If ' Version objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry3, intValue3 objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry4, intValue4 If intValue3 <> "" Then .Offset(0, 4).Value = intValue3 & "." & intValue4 End If ' Taille objReg.GetDWORDValue HKLM, strKey & strSubkey, strEntry5, intValue5 If intValue5 <> "" Then .Offset(0, 5).Value = Round(intValue5 / 1024, 3) & " Mo" End If End With Next '--- Mise en page Finale : tri et largeur des colonnes Const xlAscending = 1 Const xlYes = 1 'Const xlGuess = 0 'Tri (sélectionne les entêtes) .Range("A3").Select .Range("A2:F" & .Range("A1").End(xlDown).Row).Sort .Range("A3"), xlAscending, .Range("B3"), , xlAscending, .Range("C3"), xlAscending, xlYes 'Largeur de colonne objExcel.Columns("A:F").AutoFit End With '--- Paramètrage comportement Excel (à choisir suivant l'effet désiré) objExcel.Application.ScreenUpdating = True 'True -> Affiche le résultat (temporairement) objExcel.Application.Visible = False 'True -> remet la visibilité objExcel.Application.DisplayAlerts = True 'True -> Questionne pour la sauvegarde '--- Sauvegarde du travail et Fermeture objClasseur.Save 'Sauvegarde le classeur objClasseur.Close 'Fermeture d'Excel objExcel.Quit() MsgBox "Opération Terminée avec succès.", vbInformation + vbOKOnly + vbApplicationModal + 0, "BILAN" '--- Supprime les déclarations Set objReg = Nothing Set WshNetwork = Nothing Set oshLstLog = Nothing Set objClasseur = Nothing Set objExcel = Nothing End Function Function strGetComputerName() Dim WshNetwork Set WshNetwork = WScript.CreateObject("WScript.Network") strGetComputerName = WshNetwork.ComputerName Set WshNetwork = Nothing End Function