Функция PING на VBA с изменяемым размером ICMP пакета

Function Ping(ByVal addr$) As Boolean
    On Error Resume Next
    Ping = GetObject("winmgmts:").ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = '" & addr$ & "'").ItemIndex(0).StatusCode = 0
End Function

Function InetAvailable() As Boolean
    InetAvailable = Ping("bing.com"): If Not InetAvailable Then InetAvailable = Ping("google.com")
End Function

Sub TestPingFunction()
    If Ping("ComputerName") Then ПутьКПапке = "\\ComputerName\files"
    If Ping("ya.ru") Then MsgBox "Интернет доступен!"
    If Not Ping("192.168.0.2") Then MsgBox "Компьютер с IP адресом 192.168.0.2 недоступен в сети!"
End Sub

Function PingResponseTime(ByVal ComputerName$, Optional ByVal BufferSize% = 32) As Long
    ' Выполняет ICMP запрос (ping) до адреса ComputerName пакетами размером BufferSize% байтов
    ' Возвращает время отклика (в миллисекундах), если пинг прошел удачно,
    ' или -1, если ответ на запрос не получен.

    Dim oPingResult As Variant: PingResponseTime = -1: On Error Resume Next
    For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
        ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "' and BufferSize = " & BufferSize%)
        If IsObject(oPingResult) Then If oPingResult.StatusCode = 0 Then PingResponseTime = oPingResult.ResponseTime
    Next
End Function

Function PingResponseTimeEx(ByVal ComputerName$, Optional ByVal BufferSize As Long = 32) As Long
    ' Выполняет ICMP запрос (ping) до адреса ComputerName пакетами размером BufferSize% байтов
    ' Возвращает время отклика (в миллисекундах), если пинг прошел удачно,
    ' или -1, если ответ на запрос не получен.

    Dim oPingResult As Variant: PingResponseTimeEx = -1: On Error Resume Next
    For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
        ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "' and BufferSize = " & BufferSize)
        If IsObject(oPingResult) Then
            If oPingResult.StatusCode = 0 Then    ' ответ пришёл - возвращаем время отклика
                PingResponseTimeEx = oPingResult.ResponseTime
            Else    ' выводим код ошибки в окно Immediate
                Debug.Print "Ошибка ICMP запроса к адресу " & ComputerName$ & " (размер пакета: " & _
                            BufferSize & "): " & "Код ошибки " & oPingResult.StatusCode
            End If
            ' описания ошибок есть здесь: http://msdn.microsoft.com/ru-ru/library/aa394350(v=VS.85).aspx
            ' например, ошибка 11010 означает "Request Timed Out" - таймаут (по умолчанию он равен 1000 мс)
        End If
    Next
End Function

Sub ПримерИспользованияPingResponseTimeEx()
    ' пингуем адрес 192.168.1.100 пакетами размером 1000 байтов
    Debug.Print PingResponseTimeEx("192.168.1.100", 1000)    ' возвращает 5 (ping успешный, отклик 5ms)

    ' пингуем Яндекс пакетами размером 99 байтов
    Debug.Print PingResponseTimeEx("ya.ru", 99)    ' возвращает 28 (ping успешный, отклик 28ms)
End Sub

Function InternetConnectionAvailable() As Boolean
    ' возвращает TRUE, если доступно соединение с Интернетом (пингуются несколько хостов)
    InternetConnectionAvailable = False
    If Ping("yandex.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("ya.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("mail.ru") Then InternetConnectionAvailable = True: Exit Function
    If Ping("rambler.ru") Then InternetConnectionAvailable = True: Exit Function
End Function

Sub ПримерИспользования()
    If Not InternetConnectionAvailable Then ' проверяем доступ к основным сайтам
        MsgBox "Сначала подключите интернет (или отключите брандмауэр), " & _
               "а потом запускайте макрос", vbCritical, "Недоступен интернет"
        Exit Sub
    End If
    ' далее идёт код, взаимодействующий с интернетом (почта, FTP, HTTP и т.д.)
End Sub