Макрос ping для 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 ПутьКПапке = "\ComputerNamefiles"
    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

Ping IP-адрес с кодом VBA и результаты возврата в Excel

‘===============================================================================

Const CONST_Cln_IP As Integer = 2

Sub GetIPStatus()

Dim Cell As Range

Dim ipRng As Range

Dim Result As String

Dim Wks As Worksheet

Set Wks = Worksheets(«SPIN»)

Select Case MsgBox(«Проверить все?», 35, «Пинг всех IP»)

Case 6 ‘ Да

Set ipRng = Wks.Range(«B3»)

Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)

Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

For Each Cell In ipRng

Application.StatusBar = «ping: » & Cell.Offset(0, 1).Value & » (» & Cell.Value & «)»

Result = GetPingResult(Cell)

Cell.Offset(0, -1) = Result

DoEvents

Next Cell

Case 7 ‘ Нет

‘проверка по выделенному диапазону

Set ipRng = Selection

‘по словарю проверяем строки(для исключения повторного pingА)

With CreateObject(«Scripting.Dictionary»)

For Each Cell In ipRng

If Not .exists(Cell.Row) Then

.Add Cell.Row, «»

Debug.Print Cell.Row

Application.StatusBar = «ping: » & Wks.Cells(Cell.Row, CONST_Cln_IP + 1).Value & » (» & Wks.Cells(Cell.Row, CONST_Cln_IP).Value & «)»

Result = GetPingResult(Wks.Cells(Cell.Row, CONST_Cln_IP).Value)

Wks.Cells(Cell.Row, CONST_Cln_IP).Offset(0, -1) = Result

DoEvents

End If

Next Cell

End With

Case 2 ‘ Отмена

End Select

Application.StatusBar = «»

End Sub

‘===============================================================================

У меня есть некоторый визуальный базовый код (см. ниже), который проверяет ip-соединение в columb B (из excel spreedsheet) и ставит ли он, что он подключен или недоступен в columb c, мне просто интересно, можете ли вы помочь мне бы хотелось, чтобы он «подключился», если бы какой-либо другой результат был бы красным,

также может ли этот script запускаться автоматически по часовой или ежедневной основе?

Большое спасибо,Andy

Function GetPingResult(Host)

Dim objPing As Object

Dim objStatus As Object

Dim Result As String

Set objPing = GetObject(«winmgmts:{impersonationLevel=impersonate}»). _

ExecQuery(«Select * from Win32_PingStatus Where Address = ‘» & Host & «‘»)

For Each objStatus In objPing

Select Case objStatus.StatusCode

Case 0: strResult = «Connected»

Case 11001: strResult = «Buffer too small»

Case 11002: strResult = «Destination net unreachable»

Case 11003: strResult = «Destination host unreachable»

Case 11004: strResult = «Destination protocol unreachable»

Case 11005: strResult = «Destination port unreachable»

Case 11006: strResult = «No resources»

Case 11007: strResult = «Bad option»

Case 11008: strResult = «Hardware error»

Case 11009: strResult = «Packet too big»

Case 11010: strResult = «Request timed out»

Case 11011: strResult = «Bad request»

Case 11012: strResult = «Bad route»

Case 11013: strResult = «Time-To-Live (TTL) expired transit»

Case 11014: strResult = «Time-To-Live (TTL) expired reassembly»

Case 11015: strResult = «Parameter problem»

Case 11016: strResult = «Source quench»

Case 11017: strResult = «Option too big»

Case 11018: strResult = «Bad destination»

Case 11032: strResult = «Negotiating IPSEC»

Case 11050: strResult = «General failure»

Case Else: strResult = «Unknown host»

End Select

GetPingResult = strResult

Next

Set objPing = Nothing

End Function

Sub GetIPStatus()

Dim Cell As Range

Dim ipRng As Range

Dim Result As String

Dim Wks As Worksheet

Set Wks = Worksheets(«Sheet1»)

Set ipRng = Wks.Range(«B3»)

Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)

Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

For Each Cell In ipRng

Result = GetPingResult(Cell)

Cell.Offset(0, 1) = Result

Next Cell

End Sub

I just assembled (since I did not write it from scratch) a small but useful script which can be used directly from excel. You really don’t need to run anything on command prompt or create an input/output file.The script doesn’t even need admin privileges to run. The result from the script would be stored real time in the same excel sheet. Just paste the list of computer names/IP Addresses /Urls in the sheet and hit the execute button.

You can download the excel file directly
from the below link(Don’t forget to change the file extension to .xlsm).

Ping_Script

Step 1 – Preparing Excel to run macro

You can refer to my article “Preparing excel to run sysadmin scripts” and follow the steps provided.

Step 2 – Copy the script into the “Microsoft Visual Basic for Applications” window which opens once you click on “view code” option under developers tab.

You need to copy the below code, save it and assign the sub (PingSystem) to the execute button.

‘—————————————————————————————

Sub PingSystem()

‘—-First clear the cells in Row B—————–

ClearStatusCells

‘—————————————————

Dim strcomputer As String

Application.ScreenUpdating = True

For introw = 2 To ActiveSheet.Cells(65536, 1).End(xlUp).Row

strcomputer = ActiveSheet.Cells(introw, 1).Value

‘————Call ping function and post the output in the adjacent cell——-

If Ping(strcomputer) = True Then

strpingtest = “Online”

ActiveSheet.Cells(introw, 2).Value = strpingtest

Else

ActiveSheet.Cells(introw, 2).Font.Color = RGB(200, 0, 0)

ActiveSheet.Cells(introw, 2).Value = “Offline”

End If

Next

MsgBox “Script Completed”

End Sub

Function Ping(strcomputer)

Dim objshell, boolcode

Set objshell = CreateObject(“wscript.shell”)

boolcode = objshell.Run(“ping -n 1 -w 1000 ” & strcomputer, 0, True)

If boolcode = 0 Then

Ping = True

Else

Ping = False

End If

End Function

Sub ClearStatusCells()

Range(“B2:B1000”).Clear

End Sub’———————————————————————————————

Step 3 – Perform a test run

You need to make sure that all your computer names start from cell A2 vertically downwards . The output will be saved in cell B2 respectively.

Video below shows the brief steps and way to run the script.

After well over a
decade in IT and having used Excel on and off for most of that time, I’m only
now learning how powerful Excel is!

Image: Using Excel
and VBA to nslookup and Ping Test

NSLookup

— but the original source
is jayteknews.blogspot.com, which is unfortunately now defunct (why it’s so
important to copy stuff across the internet!)

PingResult

— but the original
source is scriptorium.serve-it.nl, which is also unfortunately now defunct.

If InStr(sResponse,
«Reply From»)

If
InStr(sResponse, «TTL»)

Excel NSLookup VBA Function — NSLookup()

Note: Copied from the
sources above

Public
Function NSLookup(lookupVal As String, Optional addressOpt As Integer) As
String

    Const ADDRESS_LOOKUP = 1

    Const NAME_LOOKUP = 2

    Const AUTO_DETECT = 0

    ‘Skip everything if the field is blank

    If lookupVal <> «» Then

         Dim oFSO As Object, oShell As Object,
oTempFile As Object

         Dim sLine As String, sFilename As
String

         Dim intFound As Integer

         Set oFSO =
CreateObject(«Scripting.FileSystemObject»)

         Set oShell =
CreateObject(«Wscript.Shell»)

         ‘Handle the addresOpt operand

         ‘Regular Expressions are used to
complete a substring match for an IP Address

         ‘If an IP Address is found, a DNS Name
Lookup will be forced

         If addressOpt = AUTO_DETECT Then

             ipLookup = FindIP(lookupVal)

             If ipLookup = «» Then

                 addressOpt = ADDRESS_LOOKUP

             Else

                 addressOpt = NAME_LOOKUP

                 lookupVal = ipLookup

             End If

         ‘Do a regular expression substring
match for an IP Address

         ElseIf addressOpt = NAME_LOOKUP Then

             lookupVal = FindIP(lookupVal)

         End If

         ‘Run the nslookup command

         sFilename = oFSO.GetTempName

         oShell.Run «cmd /c nslookup
» & lookupVal & » > » & sFilename, 0, True

         Set oTempFile =
oFSO.OpenTextFile(sFilename, 1)

         Do While oTempFile.AtEndOfStream
<> True

             sLine = oTempFile.Readline

             cmdStr = cmdStr & Trim(sLine)
& vbCrLf

         Loop

         oTempFile.Close

         oFSO.DeleteFile (sFilename)

         ‘Process the result

         intFound = InStr(1, cmdStr,
«Name:», vbTextCompare)

         If intFound = 0 Then

             NSLookup = «»

             Exit Function

         ElseIf intFound > 0 Then

             ‘TODO: Cleanup with RegEx

             If addressOpt = ADDRESS_LOOKUP
Then

                 loc1 = InStr(intFound, cmdStr,
«Address:», vbTextCompare) + InStr(intFound, cmdStr,
«Addresses:», vbTextCompare)

                 loc2 = InStr(loc1, cmdStr,
vbCrLf, vbTextCompare)

                 nameStr = Trim(Mid(cmdStr,
loc1 + 8, loc2 — loc1 — 8))

             ElseIf addressOpt = NAME_LOOKUP
Then

                 loc1 = InStr(intFound, cmdStr,
«Name:», vbTextCompare)

                 loc2 = InStr(loc1, cmdStr,
vbCrLf, vbTextCompare)

                 nameStr = Trim(Mid(cmdStr,
loc1 + 5, loc2 — loc1 — 5))

             End If

         End If

         NSLookup = nameStr

     Else

         NSLookup = «N/A»

     End If

End
Function

Function
FindIP(strTest As String) As String

     Dim RegEx As Object

     Dim valid As Boolean

     Dim Matches As Object

     Dim i As Integer

     Set RegEx =
CreateObject(«VBScript.RegExp»)

     RegEx.Pattern =
«b(?:d{1,3}.){3}d{1,3}b»

     valid = RegEx.test(strTest)

     If valid Then

         Set Matches = RegEx.Execute(strTest)

         FindIP = Matches(0)

     Else

         FindIP = «»

     End If

End
Function

Excel PingResult VBA Function — PingResult()

Note: Copied from the
sources above

Option
Explicit

‘Requires
references to Microsoft
Scripting Runtime and Windows
Script Host Object Model.

‘Set
these in Tools —
References in VB
Editor.

Public
Function PingResult(sHost As String) As String

    Dim sResponse As String

    sResponse = sPing(sHost)

    If InStr(sResponse, «TTL») Then

        PingResult = «Online»

    Else

        PingResult = «Offline»

    End If

End
Function

Private
Function sPing(sHost As String) As String

    Dim oFSO As FileSystemObject, oShell As
WshShell, oTempFile As TextStream

    Dim sFilename As String

    Set oFSO = New FileSystemObject

    Set oShell = New WshShell

    sFilename = oFSO.GetTempName

    oShell.Run «%comspec% /c ping -n 1
» & sHost & » > » & sFilename, 0, True

    Set oTempFile =
oFSO.OpenTextFile(sFilename, ForReading)

    sPing = oTempFile.ReadAll

    oTempFile.Close

    oFSO.DeleteFile (sFilename)

End
Function

Public
Sub TestPing()

    MsgBox sPing(InputBox(«Enter hostname
to test»))

End
Sub