Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement