mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

Public Function Ping(ByVal ComputerName As String) As Boolean
    ' возвращает TRUE, если пинг прошел
    Dim oPingResult As Variant
    For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
        ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "'")
        If IsObject(oPingResult) Then
            If oPingResult.StatusCode = 0 Then
                Ping = True        'Debug.Print "ResponseTime", oPingResult.ResponseTime
                Exit Function
            End If
        End If
    Next
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


А эта функция (совместно с функцией Ping) поможет проверить, доступно ли соединение с интернетом на компьютере:
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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Эта программа для меня уже не актуальна (раньше я работал в техподдержке провайдера, часто пользовался в работе подобными прибамбасами)
Сейчас продолжать работу над подобными надстройками не вижу смысла, — спрос на такие решения крайне низкий (вряд ли кто купит)
Впрочем, наработки с тех времен остались, - если готовы заплатить за готовое решение, могу сделать (оформляйте заказ на сайте)

Ну я прождал три года, где обещанное?)

Бился, как проверить наличие подключения к интернету и вот здесь у Вас нашел.
Все сработало отлично.
Спасибо.

Спасибо, завтра попробую на работе

Здравствуйте, Cache.
Задача мне знакома (сам работал несколько лет в техподдержке провайдера, занимался тем же самым)
Для этого я сделал надстройку NetworkTools для Excel, где нажатием одной кнопки (из контекстного меню Excel) можно проверить наличие пинга до адреса, введенного в ячейку:

 

подскажите, плиз, какой из приведенных макросов может обрабатывать столбец с адресами?
в принципе - даже не нужно весь столбец, нужно проверять тот или иной адрес из столбца (но при этом столбец есть на каждом листе книги)
Для примера, звонит человек - не работает интернет - соответственно варианта 2 либо отвалился роутер, либо его комп (специфику почему именно так, описывать здесь смысла нет), вот и нужно проверить доступен ли роутер, если да, то проверить ip его компа - ip компа можно расположить в соседней ячейке к примеру (в данный момент в книге только ip роутеров)

metalgad, просто сейчас эта тема потеряла для меня актуальность (раньше я работал у интернет-провайдера, такая функциональность мне очень помогала в работе), поэтому я так и не закончил начатое.
Если кому-то подобная программа понадобится (закажут разработку подобной надстройки) - я доделаю её, и выложу результаты.

Можете посмотреть другую надстройку - которая позволяет выполнять пинг из контекстного меню Excel:
http://excelvba.ru/programmes/NetworkTools

Обещанного 3 года ждут? Год прошёл. Ждём дальше.

Скоро будет опубликовано решение в виде надстройки Excel, позволяющая выполнять ICMP-запросы (пинговать адреса) из ячеек Excel,

а также ещё одна многофункциональная надстройка, формирующая панель инструментов с результатами команды Ping:

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
      _  __        __  _     ____    _       ____  
__| | \ \ / / | |_ |___ \ | | | __ )
/ _` | \ \ /\ / / | __| __) | | | | _ \
| (_| | \ V V / | |_ / __/ | |___ | |_) |
\__,_| \_/\_/ \__| |_____| |_____| |____/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.