PR

Excel VBAでのPingステータス取得サンプル

IT

Excel上でIPアドレスを指定し、ボタンひとつでそれらの疎通確認を行うことが出来るExcelマクロを作成しました。

このような機能を持つツール類はその辺にころがっていると思いますが、何らかのExcelマクロを作成し、Pingの機能も追加しとこっか、みたいなことがあった時、参考にして頂けると幸いです。

サンプルのユーザインタフェース

B列にIPアドレスを入力し、「PING発行」のボタンをクリックすることで疎通確認できるというものです。

疎通確認結果がC~F列に表示され、処理終了時に「チェック終了」のメッセージボックスが出るというつくりです。

尚、PINGステータス=0(Connected)が正常です。

Pingステータス

参考までPingステータスを記しておきます。

コード詳細
0Connected
11001Buffer too small
11002Destination net unreachable
11003Destination host unreachable
11004Destination protocol unreachable
11005Destination port unreachable
11006No resources
11007Bad option
11008Hardware error
11009Packet too big
11010Request timed out
11011Bad request
11012Bad route
11013Time-To-Live (TTL) expired transit
11014Time-To-Live (TTL) expired reassembly
11015Parameter problem
11016Source quench
11017Option too big
11018Bad destination
11032Negotiating IPSEC
11050General 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

どうでもいいですが、チェックした日付・時刻をセットしています。

コメント

タイトルとURLをコピーしました