[VB/VBA] WSOCK32.DLL이용한 주기적인 Ping 모니터링

관련지식인 질문: https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102&docId=328132346#answer1

Vbs 비주얼베이직 도움이 필요합니다

iphlpapi.dll 을 이용하면 간단하게 ping 결과를 가져올 수 있습니다.

Private Declare Function GetRTTAndHopCount Lib "iphlpapi.dll" _
    (ByVal lDestIPAddr As Long, ByRef lHopCount As Long, _
    ByVal lMaxHops As Long, ByRef lRTT As Long) As Long
    
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
    (ByVal cp As String) As Long

Public Function PingIP(ByVal sIPadr As String) As Long
    Dim lIPadr As Long, lHopsCount As Long, lRTT As Long, lMaxHops As Long
    Const SUCCESS = 1
    lHopsCount = 1
    lMaxHops = 5    'KT 168.126.63.1 경우 15이상이어야 작동, 느려짐
    lIPadr = inet_addr(sIPadr)
    PingIP = (GetRTTAndHopCount(lIPadr, lHopsCount, lMaxHops, lRTT) = SUCCESS)
End Function

그런데 KT DNS인 168,126,63,1 같은 경우는 lHopsCount 가 작을 경우 반응을 하지 않아서

20이상 주면 너무 시간이 오래 걸리게 됩니다.

 

그래서 아래 링크한 소스의 WSOCK32.DLL 을 이용한 PING 을 이용합니다.

https://www.vb-helper.com/howto_ping_ip_address.html

VB Helper: HowTo: Ping an IP address in Visual Basic 6

다운받은 zip파일의 SocketStuff.bas 입니다.

 

 

***********************************

 

먼저 VB6 환경에서 ListView 에 특정 IP들의 Ping 결과를 주기적으로 보여주는 프로그램을 만들었습니다.

PingStatus.zip

1.20MB

위 첨부파일에 소스가 들어 있습니다.

Moudule을 제외한 Form1 의 소스는 아래와 같습니다.

 

Private Sub Command1_Click()

    Dim tick As Long
    If Not IsNumeric(Me.Text1.Text) Then MsgBox "숫자로 입력하세요.": Exit Sub
    tick = CInt(Me.Text1.Text)
    If tick > 60 Then MsgBox "60보다 작아야 합니다.": Exit Sub
    Timer1.Enabled = False
    Debug.Print "Refreshing started at " & Time & "(interval: " & tick & ")"
    Call PingStatus
    Timer1.Interval = tick * 1000
    Timer1.Enabled = True
    
End Sub

Private Sub Command2_Click()
    
    Timer1.Enabled = False
    Debug.Print "Stopped at " & Time
End Sub

'//Above not used

Private Sub Form_Initialize()
    
     PingStatus
    
End Sub

Public Function PingStatus()

    Dim ip() As Variant
    Dim i As Integer, j As Integer
    Dim Reply As ICMP_ECHO_REPLY
    Dim result As Long
    
    'IP 대역 목록 추가
    ip = Array("192.168.0", "168.126.63")
    
    'Me.ListView1.ListItems.Clear
    With Me.ListView1
        .View = lvwReport
        .HideColumnHeaders = False
    End With
    
    With Me.ListView1.ColumnHeaders
        .Clear
        .Add , , "no", 700
        .Add , , "ip"
        .Add , , "ping result"
        .Add , , "TTL"
        .Add , , "Response", 5000
    End With

    Me.ListView1.ListItems.Clear
    
    Screen.MousePointer = vbHourglass
    DoEvents
    If Module1.SocketsInitialize Then
    
        For i = LBound(ip) To UBound(ip)
            For j = 1 To 5 '// 255 이내로 수정(대신 시간이 오래 걸림)
                With Me.ListView1.ListItems.Add(, , i & "-" & j).ListSubItems
                    .Add , , ip(i) & "." & j
                    result = Module1.ping(ip(i) & "." & j, 50, Reply)
                    .Add , , result
                    .Add , , Reply.RoundTripTime
                    .Add , , Module1.EvaluatePingResponse(result)
                End With
            Next j
        Next i
    Else
        MsgBox WINSOCK_ERROR, vbCritical
    End If
    
    'Me.ListView1.Refresh
    Screen.MousePointer = vbDefault
    
End Function

Private Sub Timer1_Timer()
    Debug.Print "Refreshing at " & Time
    PingStatus
End Sub

 

Form1에 타이머 컨트롤을 추가해야 합니다. 

 

또한 사용하려면 원하는 아이피대역을 소스의 IP배열 목록에 추가해야만 합니다

 

***********

 

다음으로 엑셀 VBA환경에서 비슷한 작동을 하는 VBA매크로를 만들었습니다.

Ping1.xlsm

0.04MB

 

갱신시간란에 원하는 갱신인터벌시간을 초단위로 입력하고

ReStart 를 누르면 원하시느 시간 단위로 Ping 테스트를 반복합니다.

무리한 테스트는 삼가기 바랍니다.

멈추려면 Stop 버튼을 누르면 됩니다.

디버그창에 로그가 남습니다.

 

소스는 아래와 같습니다.

 

Option Base 1

Public runNext As Date    'Scheduled Time

Sub pingtest()
    
    'Debug.Print PingIP("168.126.63.1")
End Sub

Function myPing(myip As Range) As String
    Dim Result As ICMP_ECHO_REPLY
    Dim rep As Long
    rep = ping(myip, 10, Result) ' change 5 to 50
    myPing = EvaluatePingResponse(rep) & " (" & Result.RoundTripTime & "ms" & ")"
End Function

Public Sub Command1_Click()

    Dim tick As Long
    If Not IsNumeric([B1]) Then MsgBox "숫자로 입력하세요.": Exit Sub
    tick = CInt([B1])
    If tick < 5 Then Debug.Print "갱신간격 너무 짧을 경우 오류 발생 가능"
    If Err Then MsgBox "정수 범위 이내여야합니다.": Exit Sub
    
    runNext = Now() + TimeSerial(0, 0, tick)
    Application.OnTime runNext, "Command1_Click", , True
    Debug.Print "Started at " & Format(Now, "hh:mm:ss") & " (interval: " & tick & ")"
    Call PingStatus
    
End Sub

Public Sub Command2_Click()
    On Error Resume Next
    Application.OnTime runNext, "Command1_Click", , False
    Debug.Print "Stopped the next schedule for " & Format(runNext, "hh:mm:ss") & _
        "(at " & Format(Now, "hh:mm:ss") & ")"
    On Error GoTo 0
End Sub

Public Function PingStatus()
    
    Dim CR As Range, IP As Range, rng As Range
    Dim i As Integer, j As Integer
    Dim Reply As ICMP_ECHO_REPLY
    Dim Result As Long
    
    'IP 대역 목록 추가
    Set CR = Range("A1").CurrentRegion
    Set CR = CR.Offset(2).Resize(CR.Rows.Count - 2) '2행 아래 영역
    
    'Screen.MousePointer = vbHourglass
    DoEvents
    If Module2.SocketsInitialize Then
    
        For Each rng In CR
            '홀수 열인 경우
            If rng.Column Mod 2 = 1 Then
                '*** PING 조회 ***
                Result = Module2.ping(rng.Value, 10, Reply)
                With rng.Offset(, 1)
                    .Font.Size = 9
                    .Font.Name = "Tahoma"
                    .HorizontalAlignment = 3
                    .Value = EvaluatePingResponse(Result) & _
                        " (" & Reply.RoundTripTime & "ms" & ")"
                    If Result = ICMP_SUCCESS Then
                        .Interior.ColorIndex = False
                    Else
                        .Interior.Color = rgbOrange
                    End If
                End With
            End If
        Next rng
    Else
        MsgBox WINSOCK_ERROR, vbCritical
    End If

    'Screen.MousePointer = vbDefault
    
End Function

Module2 의 내용은 첨부파일을 참고하세요.

Timer 대신 OnTime 을 이용해서 주기적으로 실행합니다.

 

참고로 위와 달리 A1셀에 아이피를 입력하고

B1셀에 =myPing(A1) 이런식으로 사용자 함수로도 이용할 수 있습니다.