Public Const DEFAULT_TIMEOUT_MSEC = 100 ' ping タイムアウト(ミリ秒) Public Const DEFAULT_INTERVAL_MIN = 1 ' 監視間隔(分) Public Const MSEC_ROW = 21 ' タイムアウト値のセルの行番号 Public Const MSEC_COLUMN = 3 ' タイムアウト値のセルの列番号 Public Const PING_MAX_ROW = 22 ' ping試行回数のセルの行番号 Public Const PING_MAX_COLUMN = 3 ' ping試行回数のセルの列番号 Public Const CountOK_ROW = 22 ' ping成功回数のセルの行番号 Public Const CountOK_COLUMN = 5 ' ping成功回数のセルの列番号 Public Const INTERVAL_ROW = 24 ' 監視間隔のセルの行番号 Public Const INTERVAL_COLUMN = 3 ' 監視間隔のセルの列番号 Public Const PING_NORESPONSE = 3 ' 応答なしの色(赤色) Public Const PING_ALIVE_ONCE = 8 ' 応答ありの色(水色) Public Const PING_ALIVE_INTERVAL = 4 ' 監視モード:応答ありの色(緑色) Public Timeout_msec As Long Public Interval_min As Long Public Ping_Alive_Color As Long Public StartTime As Date ' ' The IP_OPTION_INFORMATION structure describes the options to be included in the header of an IP packet ' Private Type IP_OPTION_INFORMATION Ttl As Byte ' Time to live Tos As Byte ' Type of service Flags As Byte ' IP header flags OptionsSize As Byte ' Size in bytes of options data OptionsData As Long ' Pointer to options data End Type ' ' The ICMP_ECHO_REPLY structure describes the data returned in response to an echo request. ' Private Type ICMP_ECHO_REPLY Address As Long ' Replying address Status As Long ' Reply IP_STATUS RoundTripTime As Long ' Round trip time, in milliseconds DataSize As Integer ' Reply data size, in bytes Reserved As Integer ' Reserved for system use Data As Long ' Pointer to the reply data Options As IP_OPTION_INFORMATION ' Reply options, in the form of an IP_OPTION_INFORMATION structure End Type ' ' [out] Buffer to hold any replies to the request. ' Upon return, the buffer contains an array of ICMP_ECHO_REPLY structures followed ' by the options and data for the replies. ' The buffer should be large enough to hold at least one ICMP_ECHO_REPLY structure ' plus MAX(RequestSize, 8) bytes of data since an ICMP error message contains 8 bytes of data. ' Private Type LPVOID EchoRepry As ICMP_ECHO_REPLY ' ICMP_ECHO_REPLY structures ErrorMessage(8) As Byte ' ICMP error message contains 8 bytes of data End Type ' ' The IcmpCreateFile function opens a handle on which ICMP Echo Requests can be issued. ' Private Declare Function IcmpCreateFile Lib "icmp" ( _ ) As Long ' ' The IcmpCloseHandle function closes a handle opened by a call to IcmpCreateFile. ' Private Declare Function IcmpCloseHandle Lib "icmp" ( _ ByVal IcmpHandle As Long _ ) As Boolean ' ' The IcmpSendEcho function sends an ICMP Echo request and returns any replies. ' The call returns when the time-out has expired or the reply buffer is filled. ' Private Declare Function IcmpSendEcho Lib "icmp" ( _ ByVal IcmpHandle As Long, _ ByVal DestinationAddress As Long, _ ByVal RequestData As String, _ ByVal RequestSize As Integer, _ ByVal RequestOptions As String, _ ByRef ReplyBuffer As Any, _ ByVal ReplySize As Long, _ ByVal Timeout As Long _ ) As Long ' ' The inet_addr function converts a string containing an (Ipv4) Internet Protocol dotted address ' into a proper address for the IN_ADDR structure. ' Private Declare Function inet_addr Lib "wsock32" ( _ ByVal HostName As String _ ) As Long ' ' ' Public Function ExecPing( _ ByVal IPaddress As String, _ ByVal Timeout _ ) As Boolean Dim IcmpHandle As Long Dim DestinationAddress As Long Dim RepryBuffer As LPVOID Dim ReturnCode As Long ' ' IP Address を 32bit数値に変換 ' DestinationAddress = inet_addr(IPaddress) ' ' 整数値の時のみ ping チェック ' If DestinationAddress <> -1 Then ' ' 初期化 ' IcmpHandle = IcmpCreateFile() ' ' ICMP Echo ' ReturnCode = IcmpSendEcho( _ IcmpHandle, _ DestinationAddress, _ 0, _ 0, _ 0, _ RepryBuffer, _ Len(RepryBuffer), _ Timeout) ' ' 結果判断 ' If ReturnCode = 0 Then ExecPing = False ' No Reply Else If RepryBuffer.EchoRepry.Status = 0 Then ExecPing = True ' Reply Else ExecPing = False ' Error (ex. Destination unreachable) End If End If ' ' Close ' ReturnCode = IcmpCloseHandle(IcmpHandle) End If End Function ' ' セルが IP Address かどうかをチェックする。(".") が 3つあれば IP アドレス とする。 ' Public Function CellCheck( _ ByVal IPaddress As String _ ) As Boolean Dim c As Long If Val(Left$(IPaddress, 1)) > 0 And Val(Right$(IPaddress, 3)) > 0 Then c = InStr(1, IPaddress, ".") If c > 0 Then c = InStr(c + 1, IPaddress, ".") If c > 0 Then c = InStr(c + 1, IPaddress, ".") End If End If If c > 0 Then CellCheck = True Else CellCheck = False End If Else CellCheck = False End If End Function Sub Ping実行() Dim Status As Boolean Dim Column As Long Dim Row As Long Dim ip As String Dim LoggingFlag As Boolean Dim intLogFileNo As Integer Dim LogFileName As String Dim YYYYMMDD As String Dim YYYY_MM_DD As String Dim HH_MM_SS As String ' ' 初回のみ ' If Ping_Alive_Color <= 0 Then Ping_Alive_Color = PING_ALIVE_ONCE End If ' ' マクロ動作の隠蔽 ' Application.ScreenUpdating = False ' ' Timeout 値の取得 ' Timeout_msec = Sheets("使用方法").Cells(MSEC_ROW, MSEC_COLUMN) ' ' ログを取得する場合はログのオープン ' LoggingFlag = Sheets("使用方法").Logging.Value If LoggingFlag = True Then NOWDATE = Date YYYYMMDD = Year(NOWDATE) & Right$("00" & Month(NOWDATE), 2) & Right$("00" & Day(NOWDATE), 2) LogFileName = Workbooks(ThisWorkbook.Name).Path & "\" & "ping_" & YYYYMMDD & ".log" intLogFileNo = FreeFile Open LogFileName For Append Access Write As #intLogFileNo End If ' ' ping 試行回数・成功回数値の取得 ' PingOK = Sheets("使用方法").Cells(CountOK_ROW, CountOK_COLUMN) If Val(PingOK) < 1 Then PingOK = 1 End If PingMax = Sheets("使用方法").Cells(PING_MAX_ROW, PING_MAX_COLUMN) If Val(PingMax) < PingOK Then PingMax = PingOK End If ' ' すべてのセルを検索して ping を実行 ' For Column = ActiveSheet.Cells.SpecialCells(xlLastCell).Column To 1 Step -1 For Row = ActiveSheet.Cells.SpecialCells(xlLastCell).Row To 1 Step -1 ' ' IP アドレスが含まれたセルならば ' Cells(Row, Column).Select ip = ActiveSheet.Cells(Row, Column) If CellCheck(ip) = True Then ' ' 指定回数 ping を実行 ' CountOK = 0 For p = 1 To PingMax Status = ExecPing(ip, Timeout_msec) If Status = True Then CountOK = CountOK + 1 End If Next ' ' セルの色を決定 ' If CountOK < PingOK Then With Selection.Interior .ColorIndex = PING_NORESPONSE .Pattern = xlSolid End With Else With Selection.Interior .ColorIndex = Ping_Alive_Color .Pattern = xlSolid End With End If ' ' チェックボックスがONの時はログに出力 ' If LoggingFlag = True Then NOWDATE = Date NOWTIME = Time YYYY_MM_DD = Year(NOWDATE) & "/" & Right$("00" & Month(NOWDATE), 2) & "/" & Right$("00" & Day(NOWDATE), 2) HH_MM_SS = Right$("00" & Hour(NOWTIME), 2) & ":" & Right$("00" & Minute(NOWTIME), 2) & ":" & Right$("00" & Second(NOWTIME), 2) percent = Right("000" & Int(100 * CountOK / PingMax), 3) If CountOK < PingOK Then Print #intLogFileNo, YYYY_MM_DD & "," & HH_MM_SS & ",×," & percent & "%," & ip Else Print #intLogFileNo, YYYY_MM_DD & "," & HH_MM_SS & ",〇," & percent & "%," & ip End If End If End If Next Row Next Column ' ' ログを取得していた場合はログのクローズ ' If LoggingFlag = True Then Close #intLogFileNo End If End Sub Sub 画面クリア() Dim Column As Long Dim Row As Long Dim ip As String ' ' 監視モードの場合は OFF に ' If Ping_Alive_Color = PING_ALIVE_INTERVAL Then Ping_Alive_Color = PING_ALIVE_ONCE Application.OnTime StartTime, "監視開始", schedule:=False End If ' ' マクロ動作の隠蔽 ' Application.ScreenUpdating = False ' ' すべてのセルをクリア ' For Column = ActiveSheet.Cells.SpecialCells(xlLastCell).Column To 1 Step -1 For Row = ActiveSheet.Cells.SpecialCells(xlLastCell).Row To 1 Step -1 Cells(Row, Column).Select ip = ActiveSheet.Cells(Row, Column) If CellCheck(ip) = True Then Selection.Interior.ColorIndex = xlNone End If Next Row Next Column End Sub Sub 監視開始() Dim TimeString As String ' ' 監視モード色に ' Ping_Alive_Color = PING_ALIVE_INTERVAL ' ' 監視間隔値の取得 ' Interval_min = Sheets("使用方法").Cells(INTERVAL_ROW, INTERVAL_COLUMN) If Interval_min <= 0 Or 60 <= Interval_min Then Interval_min = DEFAULT_INTERVAL_MIN End If TimeString = "00:" & Right$("00" & Mid$(Str(Interval_min), 2, Len(Str(Interval_min)) - 1), 2) & ":00" ' ' 次の監視をスケジュール ' StartTime = Now() + TimeValue(TimeString) Application.OnTime StartTime, "監視開始" ' ' 今回のping監視 ' Call Ping実行 End Sub