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
|
