Deklarace vlastniho typu
1
2
3
4
5
Private Type ty_s_PC_Properties
    g_numb As String
    ip_add As String
    status As String
End Type

Hlavni makro pro nacteni PC z MS Excel a doplneni vysledku do tabulky
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
'this sub calls the above function using a for each loop
Sub GetIPStatus()
    
    'declaring variables
    Dim Cell As Range
    Dim ipRng As Range
    Dim Result As String
    Dim objPC As ty_s_PC_Properties
    Dim Wks As Worksheet
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    
    'this clears the current Ping Status column (not necessary but visually helpful
    Worksheets("List2").Range("B2:B10000").Clear
    
    'this starts a time to see how long the status check takes
    StartTime = Timer
    
    'setting values of variables
    Set Wks = Worksheets("List2")
    Set ipRng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
    Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
    
    
    'this is a loop that feeds each server from the list into the GetPingResult function
    For Each Cell In ipRng
        objPC = GetPingResult(Cell)
        Cell.Offset(0, 1) = objPC.ip_add
        Cell.Offset(0, 2) = objPC.status
    Next Cell
    
    'this calculates the time it took to run the script and converts it to minutes
    SecondsElapsed = Round(Round(Timer - StartTime, 2) / 60)
    
    'this displays the final time taken and lets the user know everything has completed
    MsgBox "This code ran successfully in " & SecondsElapsed & " minutes", vbInformation
 
End Sub

Funkce PING pres VBA
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
'This function does the pinging
Private Function GetPingResult(Host) As ty_s_PC_Properties
   
    'declaring variables
    Dim objPing As Object
    Dim objStatus As Object
    Dim objResult As ty_s_PC_Properties 'String
    
    'ping the host
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                            ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
    
    'report the results
    For Each objStatus In objPing
        ' --
        With objResult
            .g_numb = Host
            .ip_add = objStatus.ProtocolAddress
            .status = getStatusCode(objStatus.StatusCode)
        End With
        ' --
        GetPingResult = objResult 'strResult
    
    Next
    
    'reset object ping variable
    Set objPing = Nothing
 
End Function

Funkce pro vraceni statusu (konstanty)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Private Function getStatusCode(StatusCode) As String
    Dim strResult As String
    
    '---
    Select Case 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
    
    '---
    getStatusCode = strResult
    
End Function