EVENTVIEWER - NTLOGEVENT - EXTRACTION INFORMATIONS DU JOURNAL D'OBSERVATION DES EVÉNEMENTS WINDOWS

'Lecture des enregistrements des journaux d'événements de Windows
'Source originale : Cedric NANA, LABORATOIRE SUPINFO DES TECHNOLOGIES MICROSOFT (Equipe Recherche)
'Publiée le 11/05/2005 http://www.laboratoire-microsoft.org/scripts/14221/
'Descriptif de Win32_NTLogEvent
'http://www.secretswindows.com/index.php?rubrique=scripts&ssrubrique=WMI&page=./scripts/wmi/win32ntlogevent.htm
'
'Selection sur LogFile="Application" ou "System", Type="erreur" et TimeGenerated <= à 15h
'
On Error Resume Next 
'Création fichier resultat 
Dim resultat : resultat =  "D:\Observateur_événements_" & Replace(Date, "/","-") & ".txt"

Dim Fso      : Set Fso = CreateObject("Scripting.fileSystemObject") 
Dim Rapport  : Set Rapport = Fso.openTextFile(resultat, 2, True) 

Dim strComputer, objWMIServices, objWMIObjectSet, objWMIObject    
strComputer = "." 
Set objWMIServices  = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2") 
Set objWMIObjectSet = objWMIServices.ExecQuery _ 
   ("Select * from Win32_NTLogEvent Where (LogFile='Application' Or LogFile='system') And Type='erreur'") 
For Each objWMIObject In objWMIObjectSet
Dim MyComputer : MyComputer = objWMIObject.ComputerName 
       
If DateDiff("d", clair(objWMIObject.TimeGenerated), Now) <= 20 Then 
   Rapport.writeLine "----------------------------------------------------"     
   Rapport.writeLine "Ordinateur: "               & objWMIObject.ComputerName   
   Rapport.writeLine "Observateur d'événements: " & objWMIObject.LogFile 
   Rapport.writeLine "----------------------------------------------------" 
   Rapport.writeLine "Type: "                     & UCase(Left(objWMIObject.Type,1)) & mid(objWMIObject.Type,2) 
   Rapport.writeLine "Date: "                     & clair(objWMIObject.TimeGenerated) 
   Rapport.writeLine "Source: "                   & objWMIObject.SourceName 
   Rapport.writeLine "ID évén.: "                 & objWMIObject.EventCode  
   Rapport.writeLine "Utilisateur: "              & objWMIObject.User  
   Rapport.writeLine "Numéro d'enregistrement: "  & objWMIObject.RecordNumber 

   If Len(objWMIObject.Message) > 56 Then
      Rapport.writeLine "Description: " &vbCrLf& Cesure(objWMIObject.Message, 56) 
      Else
      Rapport.writeLine "Description: " &vbCrLf& objWMIObject.Message    
   End If

End If
Next
Rapport.Close
Set Rapport = Nothing
Set fso = Nothing : Set Rapport = Nothing
Set objWMIObjectSet = Nothing : Set objWMIServices  = Nothing

Dim WshShell : Set WshShell = CreateObject("WScript.Shell")
WshShell.Run resultat
Set WshShell = Nothing

'Envoi automatisé du mail
'Call EnvoiMail(resultat, MyComputer, Contenu)
WScript.Quit

Function clair(temps)
'tranformation de la date "aaaammjjhhmnss" en jj/mm/aaaa hh:mn
Dim debut, an, mois, jour, hhmn
	debut = left(temps,8)
	an = left(debut,4)
	mois = mid(debut,5,2)
	jour = right(debut,2)
	hhmn = " " & Mid(temps,9,2) & ":" & Mid(temps,11,2)
	clair = CStr(jour) & "/" & CStr(mois) & "/" & CStr(an) & CStr(hhmn)
	'MsgBox temps &vbCrLf& clair
End function

Function Cesure(texte,taillecesure) 
'Cette function Cesure est à améliorer
Dim posespace 
Dim textimp 
    
    While (Len(texte) > taillecesure) 
        'Vérifier si la césure ne se fait pas juste avant l'espace (apres un mot entier) : 
        If Mid(texte, taillecesure + 1, 1) = " " Then 
            'si c'est le cas , ne pas chercher d'espace 
            posespace = taillecesure 
        Else 
            'sinon, chercher un espace avant le mot en cours 
            posespace = InStrRev(Left(texte, taillecesure), " ") - 1 
        End If 
        'ajouter le texte tronqué à la sortie de la fonction 
        textimp = textimp & Left(texte, posespace) & vbCrLf   
        'tronquer le texte et recommencer la boucle 
        texte = Mid(Trim(texte), posespace + 2) 
     
    Wend 
    'ajouter le restant du texte 
    textimp = textimp & texte 
    'retourner le resultat de la fonction 
    Cesure = textimp 
End Function

28 novembre 2006 12:42:02 :

Correction de la Quéry (bug sur certains xp) Ajout d'une function Césure pour la description des messages (à améliorer) Ce script, en vbs, ne necéssite aucune install de composant.