C
crferguson
I use this set of functions in a class to test whether or not URLs are
valid. As some of you may have run into, the MSXML2.XMLHTTP does not
support timeouts and there are URLs on the Internet that will hang
until the application is stopped manually. These function resolve
that issue by allowing you to set how long to try and test the page
before releasing the call without having to Ctrl+Alt+Del the
application...
============================
Public URLStatus As Integer
Public URLResponse As String
Private o As Object
Public Function TestURL(sURL As String, Optional ByVal TimeOutSeconds
As Double = 30) As Boolean
On Error GoTo SendError
Dim TimeOut As Double, iTimeTaken As Integer
Dim sSB As String
'get the initial status bar message
sSB = Application.StatusBar
'set the timeout value in seconds
TimeOut = TimeOutSeconds
Set o = CreateObject("MSXML2.XMLHTTP")
'open the headers
pen "HEAD", sURL, True
On Error Resume Next
'send a request
o.Send
'wait for state change or timeout
iTimeTaken = 0
'loop until the page has loaded or timed out
Application.StatusBar = sSB & " (testing '" & sURL & "')"
Do Until iTimeTaken > TimeOut
Application.Wait TimeSerial(Hour(Now()), Minute(Now()),
Second(Now()) + 1)
iTimeTaken = iTimeTaken + 1
If o.ReadyState = 4 Then
'page has loaded
Exit Do
End If
Loop
Application.StatusBar = sSB
If o.ReadyState <> 4 Then
'if the readystate is still 4 then it timed out
GoTo TimedOut
End If
'record the responding status
URLStatus = o.Status
'get the related message
URLResponse = GetResponse(URLStatus)
'check to see if the response was in the valid
'range (2xx)
If URLStatus >= 200 And URLStatus <= 299 Then
TestURL = True
Else
TestURL = False
End If
ClearObjects:
Set o = Nothing
Exit Function
SendError:
Debug.Print sURL
TestURL = False
Me.URLResponse = "Invalid URL"
Me.URLStatus = 10001
GoTo ClearObjects
TimedOut:
Debug.Print sURL
TestURL = False
Me.URLStatus = 12002
Me.URLResponse = GetResponse(Me.URLStatus)
GoTo ClearObjects
End Function
Private Function GetResponse(StatusCode As Integer) As String
'translates HTTP response codes into error messages
Select Case StatusCode
Case 100: GetResponse = "Continue"
Case 101: GetResponse = "Switching protocols"
Case 200: GetResponse = "OK"
Case 201: GetResponse = "Created"
Case 202: GetResponse = "Accepted"
Case 203: GetResponse = "Non-Authoritative Information"
Case 204: GetResponse = "No Content"
Case 205: GetResponse = "Reset Content"
Case 206: GetResponse = "Partial Content"
Case 300: GetResponse = "Multiple Choices"
Case 301: GetResponse = "Moved Permanently"
Case 302: GetResponse = "Found"
Case 303: GetResponse = "See Other"
Case 304: GetResponse = "Not Modified"
Case 305: GetResponse = "Use Proxy"
Case 307: GetResponse = "Temporary Redirect"
Case 400: GetResponse = "Bad Request"
Case 401: GetResponse = "Unauthorized"
Case 402: GetResponse = "Payment Required"
Case 403: GetResponse = "Forbidden"
Case 404: GetResponse = "Not Found"
Case 405: GetResponse = "Method Not Allowed"
Case 406: GetResponse = "Not Acceptable"
Case 407: GetResponse = "Proxy Authentication Required"
Case 408: GetResponse = "Request Timeout"
Case 409: GetResponse = "Conflict"
Case 410: GetResponse = "Gone"
Case 411: GetResponse = "Length Required"
Case 412: GetResponse = "Precondition Failed"
Case 413: GetResponse = "Request Entity Too Large"
Case 414: GetResponse = "Request-URI Too Long"
Case 415: GetResponse = "Unsupported Media Type"
Case 416: GetResponse = "Requested Range Not Suitable"
Case 417: GetResponse = "Expectation Failed"
Case 500: GetResponse = "Internal Server Error"
Case 501: GetResponse = "Not Implemented"
Case 502: GetResponse = "Bad Gateway"
Case 503: GetResponse = "Service Unavailable"
Case 504: GetResponse = "Gateway Timeout"
Case 505: GetResponse = "HTTP Version Not Supported"
Case 12001: GetResponse = "Out Of Handles"
Case 12002: GetResponse = "Timeout"
Case 12003: GetResponse = "Extended Error"
Case 12004: GetResponse = "Internal Error"
Case 12005: GetResponse = "Invalid Url"
Case 12006: GetResponse = "Unrecognized Scheme"
Case 12007: GetResponse = "Name Not Resolved"
Case 12008: GetResponse = "Protocol Not Found"
Case 12009: GetResponse = "Invalid Option"
Case 12010: GetResponse = "Bad Option Length"
Case 12011: GetResponse = "Option Not Settable"
Case 12012: GetResponse = "Shutdown"
Case 12013: GetResponse = "Incorrect User Name"
Case 12014: GetResponse = "Incorrect Password"
Case 12015: GetResponse = "Login Failure"
Case 12016: GetResponse = "Invalid Operation"
Case 12017: GetResponse = "Operation Cancelled"
Case 12018: GetResponse = "Incorrect Handle Type"
Case 12019: GetResponse = "Incorrect Handle State"
Case 12020: GetResponse = "Not Proxy Request"
Case 12021: GetResponse = "Registry Value Not Found"
Case 12022: GetResponse = "Bad Registry Parameter"
Case 12023: GetResponse = "No Direct Access"
Case 12024: GetResponse = "No Context"
Case 12025: GetResponse = "No Callback"
Case 12026: GetResponse = "Request Pending"
Case 12027: GetResponse = "Incorrect Format"
Case 12028: GetResponse = "Item Not Found"
Case 12029: GetResponse = "Cannot Connect"
Case 12030: GetResponse = "Connection Aborted"
Case 12031: GetResponse = "Connection Reset"
Case 12032: GetResponse = "Force Retry"
Case 12033: GetResponse = "Invalid Proxy Request"
Case 12036: GetResponse = "Handle Exists"
Case 12037: GetResponse = "Sec Cert Date Invalid"
Case 12038: GetResponse = "Sec Cert Cn Invalid"
Case 12039: GetResponse = "Http To Https On Redir"
Case 12040: GetResponse = "Https To Http On Redir"
Case 12041: GetResponse = "Mixed Security"
Case 12042: GetResponse = "Chg Post Is Non Secure"
Case 12043: GetResponse = "Post Is Non Secure"
Case 12110: GetResponse = "Transfer In Progress"
Case 12111: GetResponse = "Dropped"
Case 12130: GetResponse = "Protocol Error"
Case 12131: GetResponse = "Not File"
Case 12132: GetResponse = "Data Error"
Case 12133: GetResponse = "End Of Data"
Case 12134: GetResponse = "Invalid Locator"
Case 12135: GetResponse = "Incorrect Locator Type"
Case 12136: GetResponse = "Not Gopher Plus"
Case 12137: GetResponse = "Attribute Not Found"
Case 12138: GetResponse = "Unknown Locator"
Case 12150: GetResponse = "Header Not Found"
Case 12151: GetResponse = "Downlevel Server"
Case 12152: GetResponse = "Invalid Server Response"
Case 12153: GetResponse = "Invalid Header"
Case 12154: GetResponse = "Invalid Query Request"
Case 12155: GetResponse = "Header Already Exists"
Case 12156: GetResponse = "Redirect Failed"
Case Else: GetResponse = "Unknown Error"
End Select
End Function
============================
I'm pretty sick right now so if there's something missing or not
working, feel free to contact me and I'll update the code. crferguson
_at_ googlesmailplace dot com
valid. As some of you may have run into, the MSXML2.XMLHTTP does not
support timeouts and there are URLs on the Internet that will hang
until the application is stopped manually. These function resolve
that issue by allowing you to set how long to try and test the page
before releasing the call without having to Ctrl+Alt+Del the
application...
============================
Public URLStatus As Integer
Public URLResponse As String
Private o As Object
Public Function TestURL(sURL As String, Optional ByVal TimeOutSeconds
As Double = 30) As Boolean
On Error GoTo SendError
Dim TimeOut As Double, iTimeTaken As Integer
Dim sSB As String
'get the initial status bar message
sSB = Application.StatusBar
'set the timeout value in seconds
TimeOut = TimeOutSeconds
Set o = CreateObject("MSXML2.XMLHTTP")
'open the headers
pen "HEAD", sURL, TrueOn Error Resume Next
'send a request
o.Send
'wait for state change or timeout
iTimeTaken = 0
'loop until the page has loaded or timed out
Application.StatusBar = sSB & " (testing '" & sURL & "')"
Do Until iTimeTaken > TimeOut
Application.Wait TimeSerial(Hour(Now()), Minute(Now()),
Second(Now()) + 1)
iTimeTaken = iTimeTaken + 1
If o.ReadyState = 4 Then
'page has loaded
Exit Do
End If
Loop
Application.StatusBar = sSB
If o.ReadyState <> 4 Then
'if the readystate is still 4 then it timed out
GoTo TimedOut
End If
'record the responding status
URLStatus = o.Status
'get the related message
URLResponse = GetResponse(URLStatus)
'check to see if the response was in the valid
'range (2xx)
If URLStatus >= 200 And URLStatus <= 299 Then
TestURL = True
Else
TestURL = False
End If
ClearObjects:
Set o = Nothing
Exit Function
SendError:
Debug.Print sURL
TestURL = False
Me.URLResponse = "Invalid URL"
Me.URLStatus = 10001
GoTo ClearObjects
TimedOut:
Debug.Print sURL
TestURL = False
Me.URLStatus = 12002
Me.URLResponse = GetResponse(Me.URLStatus)
GoTo ClearObjects
End Function
Private Function GetResponse(StatusCode As Integer) As String
'translates HTTP response codes into error messages
Select Case StatusCode
Case 100: GetResponse = "Continue"
Case 101: GetResponse = "Switching protocols"
Case 200: GetResponse = "OK"
Case 201: GetResponse = "Created"
Case 202: GetResponse = "Accepted"
Case 203: GetResponse = "Non-Authoritative Information"
Case 204: GetResponse = "No Content"
Case 205: GetResponse = "Reset Content"
Case 206: GetResponse = "Partial Content"
Case 300: GetResponse = "Multiple Choices"
Case 301: GetResponse = "Moved Permanently"
Case 302: GetResponse = "Found"
Case 303: GetResponse = "See Other"
Case 304: GetResponse = "Not Modified"
Case 305: GetResponse = "Use Proxy"
Case 307: GetResponse = "Temporary Redirect"
Case 400: GetResponse = "Bad Request"
Case 401: GetResponse = "Unauthorized"
Case 402: GetResponse = "Payment Required"
Case 403: GetResponse = "Forbidden"
Case 404: GetResponse = "Not Found"
Case 405: GetResponse = "Method Not Allowed"
Case 406: GetResponse = "Not Acceptable"
Case 407: GetResponse = "Proxy Authentication Required"
Case 408: GetResponse = "Request Timeout"
Case 409: GetResponse = "Conflict"
Case 410: GetResponse = "Gone"
Case 411: GetResponse = "Length Required"
Case 412: GetResponse = "Precondition Failed"
Case 413: GetResponse = "Request Entity Too Large"
Case 414: GetResponse = "Request-URI Too Long"
Case 415: GetResponse = "Unsupported Media Type"
Case 416: GetResponse = "Requested Range Not Suitable"
Case 417: GetResponse = "Expectation Failed"
Case 500: GetResponse = "Internal Server Error"
Case 501: GetResponse = "Not Implemented"
Case 502: GetResponse = "Bad Gateway"
Case 503: GetResponse = "Service Unavailable"
Case 504: GetResponse = "Gateway Timeout"
Case 505: GetResponse = "HTTP Version Not Supported"
Case 12001: GetResponse = "Out Of Handles"
Case 12002: GetResponse = "Timeout"
Case 12003: GetResponse = "Extended Error"
Case 12004: GetResponse = "Internal Error"
Case 12005: GetResponse = "Invalid Url"
Case 12006: GetResponse = "Unrecognized Scheme"
Case 12007: GetResponse = "Name Not Resolved"
Case 12008: GetResponse = "Protocol Not Found"
Case 12009: GetResponse = "Invalid Option"
Case 12010: GetResponse = "Bad Option Length"
Case 12011: GetResponse = "Option Not Settable"
Case 12012: GetResponse = "Shutdown"
Case 12013: GetResponse = "Incorrect User Name"
Case 12014: GetResponse = "Incorrect Password"
Case 12015: GetResponse = "Login Failure"
Case 12016: GetResponse = "Invalid Operation"
Case 12017: GetResponse = "Operation Cancelled"
Case 12018: GetResponse = "Incorrect Handle Type"
Case 12019: GetResponse = "Incorrect Handle State"
Case 12020: GetResponse = "Not Proxy Request"
Case 12021: GetResponse = "Registry Value Not Found"
Case 12022: GetResponse = "Bad Registry Parameter"
Case 12023: GetResponse = "No Direct Access"
Case 12024: GetResponse = "No Context"
Case 12025: GetResponse = "No Callback"
Case 12026: GetResponse = "Request Pending"
Case 12027: GetResponse = "Incorrect Format"
Case 12028: GetResponse = "Item Not Found"
Case 12029: GetResponse = "Cannot Connect"
Case 12030: GetResponse = "Connection Aborted"
Case 12031: GetResponse = "Connection Reset"
Case 12032: GetResponse = "Force Retry"
Case 12033: GetResponse = "Invalid Proxy Request"
Case 12036: GetResponse = "Handle Exists"
Case 12037: GetResponse = "Sec Cert Date Invalid"
Case 12038: GetResponse = "Sec Cert Cn Invalid"
Case 12039: GetResponse = "Http To Https On Redir"
Case 12040: GetResponse = "Https To Http On Redir"
Case 12041: GetResponse = "Mixed Security"
Case 12042: GetResponse = "Chg Post Is Non Secure"
Case 12043: GetResponse = "Post Is Non Secure"
Case 12110: GetResponse = "Transfer In Progress"
Case 12111: GetResponse = "Dropped"
Case 12130: GetResponse = "Protocol Error"
Case 12131: GetResponse = "Not File"
Case 12132: GetResponse = "Data Error"
Case 12133: GetResponse = "End Of Data"
Case 12134: GetResponse = "Invalid Locator"
Case 12135: GetResponse = "Incorrect Locator Type"
Case 12136: GetResponse = "Not Gopher Plus"
Case 12137: GetResponse = "Attribute Not Found"
Case 12138: GetResponse = "Unknown Locator"
Case 12150: GetResponse = "Header Not Found"
Case 12151: GetResponse = "Downlevel Server"
Case 12152: GetResponse = "Invalid Server Response"
Case 12153: GetResponse = "Invalid Header"
Case 12154: GetResponse = "Invalid Query Request"
Case 12155: GetResponse = "Header Already Exists"
Case 12156: GetResponse = "Redirect Failed"
Case Else: GetResponse = "Unknown Error"
End Select
End Function
============================
I'm pretty sick right now so if there's something missing or not
working, feel free to contact me and I'll update the code. crferguson
_at_ googlesmailplace dot com