MyTetra Share
Делитесь знаниями!
Ping IP-адрес с кодом VBA и результаты возврата в Excel
Время создания: 31.07.2019 22:37
Текстовые метки: vba, ip
Раздел: !Закладки - VBA
Запись: adgaver/mytetra_base_New/master/base/1523184533mfwkay8q86/text.html на raw.githubusercontent.com

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

Так же в этом разделе:
 
MyTetra Share v.0.55
Яндекс индекс цитирования