Hallo Wer-Weiss-Was Gemeinde!
arbeite mich gerade in VB ein (MS VB 6.5 hauptsächlich mit Excel 2007).
Nun würde ich gerne den Windows Event Viewer auslesen (Ausführen…/„eventvwr“) und hier im speziellen den Bereich „System“.
Ziel ist es, die früheste und späteste Uhrzeit von Einträgen je Tag zu ermitteln. Eine Methode zum Auslesen würde vorerst reichen, die Auswertung bekomm ich sicher allein zusammen 
Danke und Grüße
Mole
arbeite mich gerade in VB ein (MS VB 6.5 hauptsächlich mit
Excel 2007).
Nun würde ich gerne den Windows Event Viewer auslesen
(Ausführen…/„eventvwr“) und hier im speziellen den Bereich
„System“.
Ziel ist es, die früheste und späteste Uhrzeit von Einträgen
je Tag zu ermitteln. Eine Methode zum Auslesen würde vorerst
reichen, die Auswertung bekomm ich sicher allein zusammen
Hallo Mole,
du suchst VBA-Code (für Excel 2007) keinen VB-Code!
In einem reinen Excel-Forum (=VBA) wollte auch einer Datümer aus eventvwr auslesen.
Jemand hat ihm drei Codes gebastelt.
Die liefen anfangs nicht, war aber nur eine Winzigkeit, dann liefen alle drei bei mir (Excel 2000-VBA)
Teste sie einfach mal ob sie in etwa das machen was du brauchen könntest.
Es sind die drei oberen Codes. (Versuch1-Versuch3)
Wenn du in Google nach
event viewer vb
findest du schon Treffer mit Code. Leider sind sehr viele auf Englisch, das kann ich nicht so flüssig lesen.
Aber bei den reinen Codes ist es ja egal.
das sind dann VB-Codes, aber da die wohl APIs benutzen kann man versuchen die nach VBA umzuschreiben.
Da ist ein Beispiel dafür nach den drei Makros, das ist VB.
Gruß
Reinhard
Option Explicit
'EventType
'1 Error
'2 Warning()
'3 Information()
'4 Security audit success
'5 Security audit failure
Sub Versuch()
Dim objWMIService As Object
Dim colLoggedEvents As Object
Dim objEvent As Object
Dim lngRow As Long, strDatum As String
Dim strMessage As String
Set objWMIService = GetObject("winmgmts:" \_
& "\\" & "." & "\root\cimv2")
Set colLoggedEvents = objWMIService.ExecQuery \_
("Select \* from Win32\_NTLogEvent Where Logfile = 'System'" & \_
" and EventType = '3'")
Application.ScreenUpdating = False
Range("A2", Cells(Rows.Count, "C")).ClearContents
lngRow = 1
For Each objEvent In colLoggedEvents
lngRow = lngRow + 1
'Infotext
If IsNull(objEvent.Message) = False Then
strMessage = objEvent.Message
Do While Right$(strMessage, 1) = Chr(10) Or Right$(strMessage, 1) = Chr(13)
strMessage = Trim$(Left$(strMessage, Len(strMessage) - 1))
Loop
Cells(lngRow, "A") = strMessage
End If
''Datum
strDatum = Trim$(objEvent.TimeWritten)
If strDatum \> "" Then Cells(lngRow, "B") = \_
CDate(Mid(strDatum, 7, 2) & "." & Mid(strDatum, 5, 2) & "." & Mid(strDatum, 1, 4) & " " & \_
Mid(strDatum, 9, 2) & ":" & Mid(strDatum, 11, 2) & ":" & Mid(strDatum, 13, 2))
'User
Cells(lngRow, "C") = IIf(IsNull(objEvent.User), "", Trim(objEvent.User))
''andere Parameter\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Debug.Print "Category: " & objEvent.Category
' Debug.Print "Computer Name: " & objEvent.ComputerName
' Debug.Print "Event Code: " & objEvent.EventCode
' Debug.Print "Record Number: " & objEvent.RecordNumber
' Debug.Print "Source Name: " & objEvent.SourceName
' Debug.Print "Event Type: " & objEvent.Type
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Next
Application.ScreenUpdating = True
End Sub
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Sub Versuch2()
Dim objEvent
Dim objWMIService As Object
Dim colLoggedEvents As Object
Dim lngRow As Long, strDatum As String
Dim strMessage As String
Set objWMIService = GetObject("winmgmts:" \_
& "\\" & "." & "\root\cimv2")
Set colLoggedEvents = objWMIService.ExecQuery \_
("Select \* from Win32\_NTLogEvent Where Logfile = 'Application'")
Application.ScreenUpdating = False
Range("A2", Cells(Rows.Count, "C")).ClearContents
lngRow = 1
For Each objEvent In colLoggedEvents
lngRow = lngRow + 1
'Infotext
If IsNull(objEvent.Message) = False Then
strMessage = objEvent.Message
Do While Right$(strMessage, 1) = Chr(10) Or Right$(strMessage, 1) = Chr(13)
strMessage = Trim$(Left$(strMessage, Len(strMessage) - 1))
Loop
Cells(lngRow, "A") = strMessage
End If
''Datum
strDatum = Trim$(objEvent.TimeWritten)
If strDatum \> "" Then Cells(lngRow, "B") = \_
CDate(Mid(strDatum, 7, 2) & "." & Mid(strDatum, 5, 2) & "." & Mid(strDatum, 1, 4) & " " & \_
Mid(strDatum, 9, 2) & ":" & Mid(strDatum, 11, 2) & ":" & Mid(strDatum, 13, 2))
'User
Cells(lngRow, "C") = IIf(IsNull(objEvent.User), "", Trim(objEvent.User))
''andere Parameter\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Debug.Print "Category: " & objEvent.Category
' Debug.Print "Computer Name: " & objEvent.ComputerName
' Debug.Print "Event Code: " & objEvent.EventCode
' Debug.Print "Record Number: " & objEvent.RecordNumber
' Debug.Print "Source Name: " & objEvent.SourceName
' Debug.Print "Event Type: " & objEvent.Type
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Next
Application.ScreenUpdating = True
End Sub
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
''Logfile =\*\*\*\*
'Application
'System
'Security
''EventType =\*\*
'1 Error
'2 Warning()
'3 Information()
'4 Security audit success
'5 Security audit failure
Sub Versuch3()
Dim objEvent
Dim objWMIService As Object, colLoggedEvents As Object
Dim dtmStartDate As Object, dtmEndDate As Object
Dim strMessage As String, strDatum As String
Dim lngRow As Long
Dim SDatum As Date
SDatum = Date 'welches Datum auslesen (heute)?
Set objWMIService = GetObject("winmgmts:" \_
& "\\" & "." & "\root\cimv2")
Const CONVERT\_TO\_LOCAL\_TIME = True
Set dtmStartDate = CreateObject("WbemScripting.SWbemDateTime")
Set dtmEndDate = CreateObject("WbemScripting.SWbemDateTime")
dtmStartDate.SetVarDate SDatum, CONVERT\_TO\_LOCAL\_TIME
dtmEndDate.SetVarDate SDatum + 1, CONVERT\_TO\_LOCAL\_TIME
Set objWMIService = GetObject("winmgmts:" \_
& "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
Set colLoggedEvents = objWMIService.ExecQuery \_
("Select \* from Win32\_NTLogEvent Where TimeWritten \>= '" \_
& dtmStartDate & "' and TimeWritten "" Then Cells(lngRow, "B") = \_
CDate(Mid(strDatum, 7, 2) & "." & Mid(strDatum, 5, 2) & "." & Mid(strDatum, 1, 4) & " " & \_
Mid(strDatum, 9, 2) & ":" & Mid(strDatum, 11, 2) & ":" & Mid(strDatum, 13, 2))
'User
Cells(lngRow, "C") = IIf(IsNull(objEvent.User), "", Trim(objEvent.User))
''andere Parameter\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Debug.Print "Category: " & objEvent.Category
' Debug.Print "Computer Name: " & objEvent.ComputerName
' Debug.Print "Event Code: " & objEvent.EventCode
' Debug.Print "Record Number: " & objEvent.RecordNumber
' Debug.Print "Source Name: " & objEvent.SourceName
' Debug.Print "Event Type: " & objEvent.Type
'\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Next
Application.ScreenUpdating = True
End Sub
'*****************************************************************************************
Private Type EVENTLOGRECORD
Length As Long ' Length of full record 0
Reserved As Long ' Used by the service 4
RecordNumber As Long ' Absolute record number 8
TimeGenerated As Long ' Seconds since 1-1-1970 12
TimeWritten As Long 'Seconds since 1-1-1970 16
EventID As Long ' 20
EventType As Integer '24
NumStrings As Integer '26
EventCategory As Integer '28
ReservedFlags As Integer ' For use with paired events (auditing) 30
ClosingRecordNumber As Long 'For use with paired events (auditing) 32
StringOffset As Long ' Offset from beginning of record 36
UserSidLength As Long '40
UserSidOffset As Long '44
DataLength As Long '48
DataOffset As Long ' Offset from beginning of record 52
End Type
Private Declare Function ReadEventLog Lib "advapi32.dll" Alias "ReadEventLogA" (ByVal hEventLog As Long, ByVal dwReadFlags As Long, ByVal dwRecordOffset As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, pnBytesRead As Long, pnMinNumberOfBytesNeeded As Long) As Long
Private Declare Function OpenEventLog Lib "advapi32.dll" Alias "OpenEventLogA" (ByVal lpUNCServerName As String, ByVal lpSourceName As String) As Long
Private Declare Function CloseEventLog Lib "advapi32.dll" (ByVal hEventLog As Long) As Long
Private Declare Function GetOldestEventLogRecord Lib "advapi32.dll" (ByVal hEventLog As Long, OldestRecord As Long) As Long
Private Declare Function GetNumberOfEventLogRecords Lib "advapi32.dll" (ByVal hEventLog As Long, NumberOfRecords As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Any) As Long
'Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
Public Const EVENTLOG\_SECURITY = "Security" '"Security" '+ Chr$(0)
Public Const EVENTLOG\_APPLICATION = "Application" '+ Chr$(0)
Public Const EVENTLOG\_SYSTEM = "System" '+ Chr$(0)
Public Const EVENTLOG\_SEQUENTIAL\_READ = &H1
Public Const EVENTLOG\_SEEK\_READ = &H2
Public Const EVENTLOG\_FORWARDS\_READ = &H4
Public Const EVENTLOG\_BACKWARDS\_READ = &H8
Public Const EVENTLOG\_SUCCESS = &H0
Public Const EVENTLOG\_ERROR\_TYPE = &H1
Public Const EVENTLOG\_WARNING\_TYPE = &H2
Public Const EVENTLOG\_INFORMATION\_TYPE = &H4
Public Const EVENTLOG\_AUDIT\_SUCCESS = &H8
Public Const EVENTLOG\_AUDIT\_FAILURE = &H10
Private Const HKEY\_LOCAL\_MACHINE = &H80000002
Private Const FORMAT\_MESSAGE\_FROM\_HMODULE = &H800
Private Const FORMAT\_MESSAGE\_FROM\_SYSTEM = &H1000
Private Const FORMAT\_MESSAGE\_IGNORE\_INSERTS = &H200
Private Const FORMAT\_MESSAGE\_ARGUMENT\_ARRAY = &H2000
Private Const LOAD\_LIBRARY\_AS\_DATAFILE As Long = 2&
' First hint of the hack we are going to do...
Public Type HackLog
s1 As String
s2 As String
s3 As String
s4 As String
s5 As String
s6 As String
s7 As String
s8 As String
s9 As String
s10 As String
End Type
Public Sub vbReadEventLog()
Dim hEventLog As Long
Dim lResult As Long
Dim lRecords As Long
Dim lOldestRecord As Long
Dim lReadFlags As Long
Dim myEventLogRecord As EVENTLOGRECORD
Dim strBuffer As String
Dim lBytesToRead As Long
Dim lBytesRead As Long
Dim lMinNumBytesNeeded As Long
Dim lRecordOffset As Long
Dim strSPlitter() As String
Dim lp As Long
hEventLog = OpenEventLog("", EVENTLOG\_SYSTEM) ' We'll be looking at local machine
If hEventLog Then
lResult = GetOldestEventLogRecord(hEventLog, lOldestRecord)
lResult = GetNumberOfEventLogRecords(hEventLog, lRecords)
If lResult Then
lReadFlags = EVENTLOG\_BACKWARDS\_READ Or EVENTLOG\_SEEK\_READ
strBuffer = Space(1024)
lBytesToRead = 0
For lp = lOldestRecord + lRecords - 1 To lOldestRecord + lRecords - 1 - 24 Step -1 'lOldestRecord To lOldestRecord + lRecords - 1 ' Read one at a time (optimise by reading ALL)
lRecordOffset = lp
'get Bytes necessary
strBuffer = Space(0)
lBytesToRead = 0
lResult = ReadEventLog(hEventLog, lReadFlags, lRecordOffset, strBuffer, lBytesToRead, lBytesRead, lMinNumBytesNeeded)
If lResult = False Then
strBuffer = Space(lMinNumBytesNeeded)
lBytesToRead = lMinNumBytesNeeded
lResult = ReadEventLog(hEventLog, lReadFlags, lRecordOffset, strBuffer, lBytesToRead, lBytesRead, lMinNumBytesNeeded)
End If
CopyMemory myEventLogRecord, ByVal strBuffer, Len(myEventLogRecord)
'Debug.Print myEventLogRecord.EventID And &H3FFF
strSPlitter = Split(Mid(strBuffer, 57, myEventLogRecord.UserSidOffset + myEventLogRecord.UserSidLength - 58), Chr(0))
Debug.Print strSPlitter(0) 'Source
Debug.Print strSPlitter(1) 'Computer
Dim fred As String
fred = Mid(strBuffer, myEventLogRecord.StringOffset + 1, myEventLogRecord.DataOffset - myEventLogRecord.StringOffset)
Debug.Print DateAdd("s", myEventLogRecord.TimeGenerated, "1/Jan/1970 00:00:00") ' Daylight savings time not included...
LocateMessage myEventLogRecord.EventID, strSPlitter(0), fred, "System"
Debug.Print fred
Next
End If
End If
' Clean up if we found a log file
If hEventLog Then
CloseEventLog hEventLog
End If
End Sub
Private Function LocateMessage(ByVal EventID As Long, strSource As String, strArg As String, strLog As String) As Long
Dim hKey As Long
Dim lType As Long
Dim strBuffer As String
Dim lSize As Long
Dim hModule As Long
'dim strMessage as string
Dim result As Long
Dim strArrayArg() As String
Dim strTemp As String
RegOpenKey HKEY\_LOCAL\_MACHINE, "SYSTEM\CurrentControlSet\Services\EventLog\" & strLog & "\" & strSource, hKey
RegQueryValueEx hKey, "EventMessageFile", 0&, lType, 0, lSize
strBuffer = Space(lSize)
result = RegQueryValueEx(hKey, "EventMessageFile", 0&, lType, ByVal strBuffer, lSize)
strTemp = "" 'Space(1024)
result = 0
result = ExpandEnvironmentStrings(strBuffer, strTemp, 0)
strTemp = Space(result)
ExpandEnvironmentStrings strBuffer, strTemp, result
strBuffer = strTemp
hModule = LoadLibraryEx(strBuffer, 0&, LOAD\_LIBRARY\_AS\_DATAFILE)
strArrayArg = Split(strArg, Chr(0))
Dim fred As HackLog
' Here comes the hack...
fred = ArrayToUDT(strArrayArg())
strBuffer = Space(1023)
result = FormatMessage(FORMAT\_MESSAGE\_FROM\_HMODULE Or FORMAT\_MESSAGE\_FROM\_SYSTEM Or FORMAT\_MESSAGE\_ARGUMENT\_ARRAY, ByVal hModule, EventID, 0&, strBuffer, Len(strBuffer), fred) 'Or FORMAT\_MESSAGE\_IGNORE\_INSERTS
'Beep
FreeLibrary hModule
If result Then strArg = Left(strBuffer, result)
LocateMessage = True 'Left(strBuffer, result)
End Function
' From a technique illustrated by Karl E Peterson
Private Function ArrayToUDT(strArray() As String) As HackLog
Dim fred As HackLog
Dim lp As Long
For lp = LBound(strArray) To UBound(strArray)
Select Case lp
Case 0: fred.s1 = strArray(lp)
Case 1: fred.s2 = strArray(lp)
Case 2: fred.s3 = strArray(lp)
Case 3: fred.s4 = strArray(lp)
Case 4: fred.s5 = strArray(lp)
Case 5: fred.s6 = strArray(lp)
Case 6: fred.s7 = strArray(lp)
Case 7: fred.s8 = strArray(lp)
Case 8: fred.s9 = strArray(lp)
Case 9: fred.s10 = strArray(lp)
End Select
Next
ArrayToUDT = fred
End Function
Hallo Reinhard,
Vielen Dank für die Codes, werd sie gleich mal testen (insb. 1 und 2)
Jo VB vs VBA is klar, passt im Excel Forum wohl besser
War mir nur sicher, dass ich hier ne schnellere, bessere Antwort bekomm als dort 
Vielen Dank für die Codes, werd sie gleich mal testen (insb. 1
und 2)
Jo VB vs VBA is klar, passt im Excel Forum wohl besser
War mir nur sicher, dass ich hier ne schnellere, bessere
Antwort bekomm als dort
Hallo Mole,
nö, das VB-Brett ist schon richtig, denn der Excel=VBA Anteil ist vernachlässigbar.
Ob man die Ergebnisse des Auslesens nun in Vb in einer Textbox o.ä. anzeigt was ja auch in Vba geht oder in Word mit Word-Vba in einer Word-Tabelle ist egal.
Insofern st es schon VB und passt in dieses Brett. Übrigens den Ursrungscode für die drei Codes den fand derjenige als VBS-Code im Internet )
reines Vb ist Vb 4.0, VB5.0, VB6.0, danach ist Schluß mit VB in diesem Brett, VB.NET gehört dann ins .NET Brett. Wird aiuch VB2010 genannt oder so.
Wenn also jemand VB 6.0 hat, also das letzte reine VB-Programm, der kennt keine version 6.5.
Die hat MS so genannt in seinen Office-VBAs ab 2007.
Deshalb steht es auch im Vb-Editor von 2007-VBA.
Oder so in etwa oder ungefähr verhält sich das Ganze *glaub*
Und, der Betreff/Artikelfolge passt auch eher ins VB-Archiv als ins Excel-Archiv.
Gruß
Reinhard