Excel上でIPアドレスを指定し、ボタンひとつでそれらの疎通確認を行うことが出来るExcelマクロを作成しました。
このような機能を持つツール類はその辺にころがっていると思いますが、何らかのExcelマクロを作成し、Pingの機能も追加しとこっか、みたいなことがあった時、参考にして頂けると幸いです。
サンプルのユーザインタフェース
B列にIPアドレスを入力し、「PING発行」のボタンをクリックすることで疎通確認できるというものです。
疎通確認結果がC～F列に表示され、処理終了時に「チェック終了」のメッセージボックスが出るというつくりです。
尚、PINGステータス＝0(Connected)が正常です。
Pingステータス
参考までPingステータスを記しておきます。
| コード | 詳細 |
|---|---|
| 0 | Connected |
| 11001 | Buffer too small |
| 11002 | Destination net unreachable |
| 11003 | Destination host unreachable |
| 11004 | Destination protocol unreachable |
| 11005 | Destination port unreachable |
| 11006 | No resources |
| 11007 | Bad option |
| 11008 | Hardware error |
| 11009 | Packet too big |
| 11010 | Request timed out |
| 11011 | Bad request |
| 11012 | Bad route |
| 11013 | Time-To-Live (TTL) expired transit |
| 11014 | Time-To-Live (TTL) expired reassembly |
| 11015 | Parameter problem |
| 11016 | Source quench |
| 11017 | Option too big |
| 11018 | Bad destination |
| 11032 | Negotiating IPSEC |
| 11050 | General failure |
| その他 | Unknown host |
コード11003(Destination host unreachable)は「宛先ホストに到達できません」です。
コード11010(Request timed out)は「要求がタイムアウトしました」です。
サンプルコード
「PING発行」ボタンのサンプルコードです。
Private Sub CommandButton1_Click()
Dim Cell As Range
Dim ipRng As Range
Dim RngEnd As Range
Dim Wks As Worksheet
Dim objPing As Object
Dim objStatus As Object
Dim strStatus As String
Dim strResult As String
Dim ret As Variant
Set Wks = Worksheets("チェック")
Set ipRng = Wks.Range("B4")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Range("C4:f551176").ClearContents
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
For Each Cell In ipRng
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
ExecQuery("Select * from Win32_PingStatus Where Address = '" & Cell & "'")
For Each objStatus In objPing
Select Case objStatus.StatusCode
Case 0: strResult = "Connected"
Case 11001: strResult = "Buffer too small"
Case 11002: strResult = "Destination net unreachable"
Case 11003: strResult = "Destination host unreachable"
Case 11004: strResult = "Destination protocol unreachable"
Case 11005: strResult = "Destination port unreachable"
Case 11006: strResult = "No resources"
Case 11007: strResult = "Bad option"
Case 11008: strResult = "Hardware error"
Case 11009: strResult = "Packet too big"
Case 11010: strResult = "Request timed out"
Case 11011: strResult = "Bad request"
Case 11012: strResult = "Bad route"
Case 11013: strResult = "Time-To-Live (TTL) expired transit"
Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
Case 11015: strResult = "Parameter problem"
Case 11016: strResult = "Source quench"
Case 11017: strResult = "Option too big"
Case 11018: strResult = "Bad destination"
Case 11032: strResult = "Negotiating IPSEC"
Case 11050: strResult = "General failure"
Case Else: strResult = "Unknown host"
End Select
If IsNull(objStatus.StatusCode) Then
strStatus = "NULL"
Else
strStatus = objStatus.StatusCode
End If
Next
Set objPing = Nothing
Cell.Offset(0, 1) = strStatus
Cell.Offset(0, 2) = strResult
If strStatus = "0" Then
Cell.Offset(0, 1).Font.ColorIndex = 0
Cell.Offset(0, 2).Font.ColorIndex = 0
Else
Cell.Offset(0, 1).Font.ColorIndex = 3
Cell.Offset(0, 2).Font.ColorIndex = 3
End If
Cell.Offset(0, 3) = Date
Cell.Offset(0, 4) = Time
Next Cell
ret = MsgBox("チェック終了", Title:="機器接続確認", Buttons:=vbOKOnly)
End Sub
行ごとの解説
Set Wks = Worksheets("チェック")“チェック”というワークシート名にしています（ごめんなさい。ユーザインタフェースのところで説明しておくべきでした）
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))反復の条件を設定しています。
ExecQuery("Select * from Win32_PingStatus Where Address = '" & Cell & "'")Win32APIでPingStatusを取得しています。
Select Case objStatus.StatusCode
Case 0: strResult = "Connected"
Case 11001: strResult = "Buffer too small"
・
・
・
Case 11050: strResult = "General failure"
Case Else: strResult = "Unknown host"
End Selectステータスコード値に対する説明をセットしています。
Cell.Offset(0, 1).Font.ColorIndex = 3
Cell.Offset(0, 2).Font.ColorIndex = 3どうでもいいですが、エラーは赤字にしています。
Cell.Offset(0, 3) = Date
Cell.Offset(0, 4) = Timeどうでもいいですが、チェックした日付・時刻をセットしています。
コメント