Макросы в Excel

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

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