Sub AAASAD()
Dim strFullFileName As String
strFullFileName = "http://hiprog.com/index.php?option=com_content&task=view&id=251661563&Itemid=35"
If WMIPing(strFullFileName) = False Then
MsgBox "Сайт недоступен:" & vbCr & strFullFileName
Else
MsgBox "Сайт доступен:" & vbCr & strFullFileName
End If
End Sub

Function WMIPing(strAdr As String) As Boolean
Dim objPing As Object
Dim objStatus As Object
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
    ExecQuery("select * from Win32_PingStatus where address = '" & strAdr & "'")
    For Each objStatus In objPing
        If IsNull(objStatus.StatusCode) Or objStatus.StatusCode <> 0 Then
            WMIPing = False
        Else
            WMIPing = True
        End If
    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()

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