Option Explicit
' ------------------------------
'  パソコンごとの設定(ここから)
' ------------------------------
Const strMailFrom = "□□□@□□□□.□□.□□" ' 送信元メールアドレス
Const strMailTo = "□□□□@□□□□.□□.□□" ' 送信先メールアドレス
Const strSMTPServer = "□□□□.□□.□□" ' SMTPサーバ
Const intSMTPPort = 25 ' SMTPポート
Const strSubjectOK = "○ログ収集テスト" ' 正常時の件名
Const strSubjectNG = "●ログ収集テスト" ' 異常時の件名
Const intInterval = 1442 ' イベントログを収集する期間(分)
' 抽出条件
Const strWhere0 = "Logfile='System' or Logfile='Application'" ' システムとアプリケーションのログを収集
Const strWhere1 = "SourceName<>'MSSQLServer' or EventCode<>'19011'" ' SQL-Server起動時に出ることがあるが無視
Const strWhere2 = "SourceName<>'W3SVC'" ' W3SVC(IIS)の警告を無視
Const strWhere3 = "SourceName<>'DNS'" ' DNS関連のメッセージを無視
Const strWhere4 = ""
Const strWhere5 = ""
Const strWhere6 = ""
Const strWhere7 = ""
Const strWhere8 = ""
Const strWhere9 = ""
' 例)
' Logfile='System' or Logfile='Application' ← システムかアプリケーション
' SourceName<>'SecurityCenter' and SourceName<>'Service Control Manager' ← 特定ソースの除外
' EventCode<>'33' and EventCode<>'7035' ← 特定イベントコードの除外
' ------------------------------
'  パソコンごとの設定(ここまで)
' ------------------------------

' ------------
'  変数の宣言
' ------------
dim dtmStartDateTime
dim strBias
dim strQuery
dim strComputer
dim objWMIService
dim colLoggedEvents
dim objEvent
dim intEventCount
dim intErrorCount
dim intI
dim intJ
dim strSubject
dim strTextBody
dim strKeyLogfile

' --------------------------------------------------
'  対象とする開始日時を変数(dtmStartDateTime)に編集
' --------------------------------------------------
On Error Resume Next ' エラー中断を停止
' XPならOK、2000ではエラーになる
Set dtmStartDateTime = CreateObject("WbemScripting.SWbemDateTime")
if Err = 0 then
    On Error goto 0 ' エラー中断を再開
    ' dtmStartDateTimeをSWbemで編集
    dtmStartDateTime.SetVarDate DateAdd("n",- intInterval,Now), True

else
    Error.Clear
    On Error goto 0 ' エラー中断を再開
    dim objSWbemServices
    dim objTimeZone
    dim colTimeZone
    strComputer = "."
    ' 時差(分)を取得
    Set objSWbemServices = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colTimeZone = objSWbemServices.ExecQuery ("SELECT * FROM Win32_TimeZone")
    For Each objTimeZone in colTimeZone
        strBias = objTimeZone.Bias
    Next
    ' dtmStartDateTimeをコーディングで編集
    dtmStartDateTime = DateAdd("n",- intInterval,Now)
    dtmStartDateTime = Year(dtmStartDateTime) & _
                       right("0" & Month(dtmStartDateTime),2) & _
                       right("0" & Day(dtmStartDateTime),2) & _
                       right("0" & Hour(dtmStartDateTime), 2) & _
                       right("0" & Minute(dtmStartDateTime), 2) & _
                       right("0" & Second(dtmStartDateTime), 2) & ".000000"
    if strBias < 0 then
        dtmStartDateTime = dtmStartDateTime & "-" & Abs(strBias)
    else
        dtmStartDateTime = dtmStartDateTime & "+" & Abs(strBias)
    end if

end if
' -----------------------------------
'  WMIからイベントログを参照する準備
' -----------------------------------
strComputer = "." 
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
strQuery = "Select * from Win32_NTLogEvent Where (EventType='1' or EventType='2' or EventType='3')" ' 1,2,3のイベントを見ます。
strQuery = strQuery & " and (TimeWritten > '" & dtmStartDateTime & "')"

' 抽出条件(追加分)
if strWhere0 <> "" then
    strQuery = strQuery & " and (" & strWhere0 & ")"
end if
if strWhere1 <> "" then
    strQuery = strQuery & " and (" & strWhere1 & ")"
end if
if strWhere2 <> "" then
    strQuery = strQuery & " and (" & strWhere2 & ")"
end if
if strWhere3 <> "" then
    strQuery = strQuery & " and (" & strWhere3 & ")"
end if
if strWhere4 <> "" then
    strQuery = strQuery & " and (" & strWhere4 & ")"
end if
if strWhere5 <> "" then
    strQuery = strQuery & " and (" & strWhere5 & ")"
end if
if strWhere6 <> "" then
    strQuery = strQuery & " and (" & strWhere6 & ")"
end if
if strWhere7 <> "" then
    strQuery = strQuery & " and (" & strWhere7 & ")"
end if
if strWhere8 <> "" then
    strQuery = strQuery & " and (" & strWhere8 & ")"
end if
if strWhere9 <> "" then
    strQuery = strQuery & " and (" & strWhere9 & ")"
end if
Set colLoggedEvents = objWMIService.ExecQuery (strQuery)
'Wscript.Echo strQuery

intEventCount = 0 ' イベント件数を初期化
intErrorCount = 0 ' エラー件数を初期化
strTextBody = "" ' メール本文用変数を初期化
strKeyLogfile = "" ' ログの種類変数を初期化

' -----------------------------------
'  WMIからイベントログを参照して編集
' -----------------------------------
if colLoggedEvents.Count > 0 then
    dim strLogfile()
    dim intRecordNumber()
    dim strType()
    dim strTimeWritten()
    dim strEventCode()
    dim strSourceName()
    dim strMessage()

    For Each objEvent in colLoggedEvents 
        intEventCount = intEventCount + 1
        redim Preserve strLogfile(intEventCount)
        redim Preserve intRecordNumber(intEventCount)
        redim Preserve strType(intEventCount)
        redim Preserve strTimeWritten(intEventCount)
        redim Preserve strEventCode(intEventCount)
        redim Preserve strSourceName(intEventCount)
        redim Preserve strMessage(intEventCount)
        ' テーブルに取り込み
        strLogfile(intEventCount) = objEvent.Logfile ' ログの種類
        intRecordNumber(intEventCount) = objEvent.RecordNumber
        ' エラーを判定
        if objEvent.EventType = "1" then
            ' エラーのとき
            intErrorCount = intErrorCount + 1
            strType(intEventCount) = "●"
        elseif objEvent.EventType = "2" then
            ' 警告のとき
            ' -------------------------------------------------------
            ' 拾う必要が無い警告を無視するよう判定を追加(ここから)
            ' -------------------------------------------------------
            if objEvent.SourceName = "@@@@" then
                strType(intEventCount) = "○"
            'elseif objEvent.SourceName = "XXXX" then
            '    strType(intEventCount) = "○"
            ' -------------------------------------------------------
            ' 拾う必要が無い警告を無視するよう判定を追加(ここまで)
            ' -------------------------------------------------------

            else
                strType(intEventCount) = "▲"
                intErrorCount = intErrorCount + 1
            end if
        else
            ' -----------------------------------------------------------
            ' アプリケーションが出すエラーを拾うよう判定を追加(ここから)
            ' -----------------------------------------------------------
            ' DNSと通信ができないとき
            if objEvent.SourceName = "@@@@" and left(objEvent.Message,4) = "@@@@" then
                strType(intEventCount) = "▲"
                intErrorCount = intErrorCount + 1
            'elseif objEvent.SourceName = "XXXX" and objEvent.EventCode = "9999" then
            '    strType(intEventCount) = "▲"
            '    intErrorCount = intErrorCount + 1
            ' -----------------------------------------------------------
            ' アプリケーションが出すエラーを拾うよう判定を追加(ここまで)
            ' -----------------------------------------------------------

            else
                strType(intEventCount) = "○"
            end if
        end if
        strType(intEventCount) = strType(intEventCount) & objEvent.Type ' エラー,警告,情報
        strTimeWritten(intEventCount) = WMIDateStringToDate(objEvent.TimeWritten) '発生日時
        strEventCode(intEventCount) = objEvent.EventCode ' イベントコード
        strSourceName(intEventCount) = objEvent.SourceName 'ソース
        strMessage(intEventCount) = objEvent.Message ' 詳細
        ' 最後の改行を除く
        if strMessage(intEventCount) & "" <> "" then
            Do While right(strMessage(intEventCount),2) = vbCrLf
                strMessage(intEventCount) = left(strMessage(intEventCount),len(strMessage(intEventCount))-2)
                if strMessage(intEventCount) & "" = "" then
                    exit do
                end if
            Loop
        end if
    Next
    ' 並べ替え
    intI = 1
    Do While intI < intEventCount
        intJ = intI + 1
        Do While intJ <= intEventCount
            if (strLogfile(intJ) < strLogfile(intI)) or _
               (strLogfile(intJ) = strLogfile(intI) and intRecordNumber(intJ) < intRecordNumber(intI)) then
                strLogfile(0) = strLogfile(intI)
                strLogfile(intI) = strLogfile(intJ)
                strLogfile(intJ) = strLogfile(0)
                intRecordNumber(0) = intRecordNumber(intI)
                intRecordNumber(intI) = intRecordNumber(intJ)
                intRecordNumber(intJ) = intRecordNumber(0)
                strType(0) = strType(intI)
                strType(intI) = strType(intJ)
                strType(intJ) = strType(0)
                strTimeWritten(0) = strTimeWritten(intI)
                strTimeWritten(intI) = strTimeWritten(intJ)
                strTimeWritten(intJ) = strTimeWritten(0)
                strEventCode(0) = strEventCode(intI)
                strEventCode(intI) = strEventCode(intJ)
                strEventCode(intJ) = strEventCode(0)
                strSourceName(0) = strSourceName(intI)
                strSourceName(intI) = strSourceName(intJ)
                strSourceName(intJ) = strSourceName(0)
                strMessage(0) = strMessage(intI)
                strMessage(intI) = strMessage(intJ)
                strMessage(intJ) = strMessage(0)
            end if
            intJ = intJ + 1
        Loop
        intI = intI + 1
    Loop

    intI = 1
    Do While intI <= intEventCount
        ' メール本文を編集
        if strTextBody <> "" then
            strTextBody = strTextBody & vbCrLf
        end if
        if strKeyLogfile <> strLogfile(intI) then
            strTextBody = strTextBody & "■" & strLogfile(intI) ' ログの種類
            strTextBody = strTextBody & vbCrLf & vbCrLf
            strKeyLogfile = strLogfile(intI)
        end if
        strTextBody = strTextBody & strType(intI) ' エラー,警告,情報

        strTextBody = strTextBody & " " & strTimeWritten(intI) '発生日時
        strTextBody = strTextBody & " (" & strEventCode(intI) & ")" ' イベントコード
        strTextBody = strTextBody & strSourceName(intI) 'ソース
        strTextBody = strTextBody & vbCrLf
        strTextBody = strTextBody & strMessage(intI) ' 詳細
        strTextBody = strTextBody & vbCrLf
        intI = intI + 1
    Loop
end if

' -----------
'  WMIの解放
' -----------
Set objEvent = Nothing
Set colLoggedEvents = Nothing
Set objWMIService = Nothing

' ----------------------------------
'  エラーの有無を判定して件名を編集
' ----------------------------------
if intErrorCount = 0 then
    strSubject = strSubjectOK
else
    strSubject = strSubjectNG
end if
strSubject = strSubject & " " & Mid(Year(Now),3) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2)
strSubject = strSubject & " " & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2)
strSubject = strSubject & " "  & intErrorCount & "/" & intEventCount & "件"

' -------------------
'  CDOでメールを送信
' -------------------
call sMail(strSubject ,strTextBody)

Function WMIDateStringToDate(dtmEventDate)
' --------------------------------------
'  WMIの日付をyyyy/mm/dd hh:nn:ssに変換
' --------------------------------------
    WMIDateStringToDate = CDate(Mid(dtmEventDate, 5, 2) & "/" & Mid(dtmEventDate, 7, 2) & "/" & Left(dtmEventDate, 4) _
            & " " & Mid(dtmEventDate, 9, 2) & ":" & Mid(dtmEventDate, 11, 2) & ":" & Mid(dtmEventDate, 13, 2))
End Function

Function sMail(strSubject ,strTextBody)
' --------------
'  メールを送信
' --------------
dim oMsg
Set oMsg = CreateObject("CDO.Message")
oMsg.From = strMailFrom
oMsg.To = strMailTo
oMsg.Subject = strSubject
oMsg.TextBody = strTextBody
oMsg.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMsg.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
oMsg.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = intSMTPPort
oMsg.Configuration.Fields.Update
oMsg.Send
End Function