随分昔にVBScriptで作った物、ちょっと最近需要が発生したので載せておく。
今はPowershellとかで作るのだろうけど、動くのでこれでまたしのいだ。
もし使う場合は文字コードS-JISで保存が必要です。
VBScript実行用のBAT
rem バッチのERRORLEVELが -1 の場合は二重起動でエラー
set RC=-1
pause
call :main 0>>"%~dpnx0"
exit /b %RC%
:main
title PING
cd /d %~dp0
cscript Ping.vbs
time /t
set RC=0
pingスクリプト本体
指定時間(秒)の間に指定回数のエラーが発生した場合にメールを送る・ログに書き込む、ということをする(はず)スクリプトです。
メールはOutlookで送るサンプル、不要であればコメントアウトや他の通知に変更して下さい。
Dim data(99,5)
Dim i
Dim intSleepms
On Error Resume Next
intSleepms = 1000
i = 0
data(i,0) = "124.150.157.157" '確認するアドレス
data(i,1) = 30 '閾値(秒)
data(i,2) = 1 '閾値(カウント数)、閾値(秒)の間にこのカウント数を超えるとアラート
data(i,3) = "" '初回エラー発生時刻保存用
data(i,4) = 0 'カウント数
data(i,5) = 0 'メール送信フラグ
i = 1
data(i,0) = "google.co.jp"
data(i,1) = 30
data(i,2) = 1
data(i,3) = ""
data(i,4) = 0
data(i,5) = 0
'ここまで
intCount = i '上記記載したカウント
If InStr(UCase(WScript.FullName), "WSCRIPT") > 0 Then
WScript.Echo "WScript では実行できません。CScriptを使用して実行してください。"
WScript.Quit
End If
Do While (0=0)
For i = 0 to intCount
Set objWMIService = GetObject("winmgmts:\\.")
Set colItems = objWMIService.ExecQuery("select * FROM Win32_PingStatus WHERE Address = '" & data(i,0) & "'")
For Each objItem in colItems
If 0 = objItem.StatusCode Then
if Data(i,3)="" then
dmy=0
else
dmy=DateDiff("s",Data(i,3),Now())
end if
WScript.Echo Time() & " " & left(data(i,0) & SPACE(50),20) & ": 閾値=" & data(i,1) & "秒 " & data(i,2) & "回 Diff="& dmy & " Err Cont =" & data(i,4) & " SendMail=" & data(i,4) & " 最終エラー時刻 " & data(i,3)
if 0 < data(i,4) then
if data(i,1) < DateDiff("s",Data(i,3),Now()) then
Data(i,3) = ""
data(i,4) = 0
data(i,5) = 0
end if
end if
Else
WScript.Echo Now() & ": " & data(i,0) & ": Request timed out."
subOutLog(Now() & ": " & data(i,0) & ": Request timed out.")
data(i,4) = data(i,4) + 1
if 1 = data(i,4) then
Data(i,3) = Now()
else
if data(i,2) <= data(i,4) and data(i,1) < DateDiff("s",Data(i,3),Now()) then
if 0 = data(i,5) then
call sendMail(data(i,0),data(i,0) & " " & data(i,1) & "秒間で" & data(i,4) & "のエラー")
data(i,5) = 1
end if
end if
end if
End If
Next
Next
WScript.Sleep(intSleepms)
Loop
'メール送信
sub sendMail(strName,strBody)
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application") '既に起動している場合に取得
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If
On Error GoTo 0
Set objMAIL = oApp.CreateItem(0)
'宛先の設定
strTemp = ""
strTemp = strTemp & "sample@hoge.home"
objMAIL.To = strTemp
'タイトル
objMAIL.Subject = "【 " & strName & " 】[MM]/[DD]"
objMAIL.cc = ""
'本文
objMAIL.BodyFormat = 3
objMAIL.Body = strBody & vbcrlf
objMAIL.Body = rep(objMAIL.Body)
objMAIL.Subject = rep(objMAIL.Subject)
objMAIL.display
'メール送信
objMAIL.send
Set objMAIL = Nothing
Set oApp = Nothing
end sub
'ログファイル出力用
sub subOutLog(strMsg)
Const ForReading = 1, ForWriting = 2, ForAppending = 8 'file open mode
Dim objFSO ' FileSystemObject
Dim objFile ' ファイル書き込み用
Dim strNow
strNow = Year(Now())
strNow = strNow & Right("0" & Month(Now()) , 2)
strFileName="IPCheck" & strNow & ".log"
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Err.Number = 0 Then
Set objFile = objFSO.OpenTextFile(strFileName, ForAppending, True)
If Err.Number = 0 Then
objFile.Write(strMsg & vbcrlf)
objFile.Close
Else
' WScript.Echo "ファイルオープンエラー: " & Err.Description
End If
Else
' WScript.Echo "エラー: " & Err.Description
End If
Set objFile = Nothing
Set objFSO = Nothing
end sub
コメント