Pasted

' Checks if ping successfully reached specified address
Public Function IsAddressReachable(ByVal url As String) As Boolean
    Dim host As String
    host = ExtractDomain(url)
    IsAddressReachable = IsHostReachable(host)
End Function
 
' Checks if ping successfully reached specified host (domain)
Public Function IsHostReachable(ByVal host As String) As Boolean
    Dim pingResult As String
    pingResult = GetPingResult(host)
    If pingResult = "Connected" Then
        IsHostReachable = True
    Else
        IsHostReachable = False
    End If
End Function
 
' Extracts domain (host) from url address.
Public Function ExtractDomain(ByVal url As String) As String
    If InStr(url, "//") Then
        url = Mid(url, InStr(url, "//") + 2)
    End If
    If Left(url, 4) Like "[Ww][Ww][Ww0-9]." Then
        url = Mid(url, 5)
    End If
    ExtractDomain = Split(url, "/")(0)
End Function
 
' Pings specific host.
Public Function GetPingResult(ByVal host As String) As String
    Dim objPing As Object
    Dim objStatus As Object
    Dim strResult As String
    
    host = Replace(host, "'", "")
 
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
        ExecQuery("Select * from Win32_PingStatus Where Address = '" & host & "'")
         
    'report the results
    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