ping監視 / ping monitoring

2021.10.28

随分昔に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

コメント