Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Type QOCINFO
    dwSize As Long
    dwFlags As Long
    dwInSpeed As Long 'байты в секунду
    dwOutSpeed As Long 'байты в секунду
End Type
Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" Alias "IsDestinationReachableA" (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long
Private Sub Main()
    Dim Ret As QOCINFO
    Ret.dwSize = Len(Ret)
    If IsDestinationReachable("rfpro.ru", Ret) = 0 Then 'вывод сообщения в зависимости от ответа
        MsgBox "Доступа нет!"
    Else
        MsgBox "Доступ есть!" + vbCrLf + _
           "Скорость передачи данных от хоста: " + Format$(Ret.dwInSpeed / 1024, "#.0") + " Кб/с," + vbCrLf + _
           "Скорость передачи данных к хосту: " + Format$(Ret.dwOutSpeed / 1024, "#.0") + " Кб/с."
    End If
End Sub

Sub TestPing()
Dim strComputer As String
strComputer = "rfpro.ru" 'имя хоста, который проверяется
If Not SystemOnline(strComputer) Then
MsgBox "Этот хост мертв: " & strComputer, vbOKOnly, "Статус хоста"
Else
MsgBox "Хост жив!", vbOKOnly, "Статус"
End If
End Sub

Function SystemOnline(ByVal ComputerName As String)
' функция возвращает True если хост пингуется
' имя хоста указывается или IP-адресом или DNS-именем
' Класс Win32_PingStatus использованный в данной функции требует  ОС Windows XP или более позднюю
Dim colPingResults As Variant
Dim oPingResult As Variant
Dim strQuery As String

' Define the WMI query
strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "'"

' запуск проверки через WMI
Set colPingResults = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)
' преобразование WMI-результата в True или False
For Each oPingResult In colPingResults
If Not IsObject(oPingResult) Then
SystemOnline = False
ElseIf oPingResult.StatusCode = 0 Then
SystemOnline = True
Else
SystemOnline = False
End If
Next
End Function