Checking Valid/Invalid Hyperlinks in Excel 2007

[tfarino]

Hey guys. This is my first post here. My question is pretty simple and it's been asked before, but mine has a tad bit of a twist.

I have an excel worksheet with column A holding a list of 900 non-clickable text hyperlinks (they can be clickable or not clickable hyperlinks, doens't matter to me).
Example: http://microsoft.com

I've got code that will check the hyperlinks to see if they are valid and it works. The only problem is all the hyperlinks show a status code of 200, OK. Even if I place a test hyperlink http://ghghfdjrj5767.com is comes up OK. I belive the reason for this is the redirect custom error page from our internet provider Cox Communications.

What I need is a way to not get 200, OK returned from a BAD/invalid hyperlink. I'd like to get a redirect status or the classic 404 status returned.

Here is the VBA code I'm using on the spreadsheet.

Sub CheckHyperlinks()
 
    Dim oColumn As Range
    Set oColumn = GetColumn() ' replace this with code to get the relevant column
 
    Dim oCell As Range
    For Each oCell In oColumn.Cells
 
        If Trim(oCell.Value) <> "" Then
        
        oCell.Offset(0, 1).Value = GetResult(oCell.Value)
        
        End If
 
    Next oCell
 
 
End Sub
 
Private Function GetResult(ByVal strUrl As String) As String
 
    On Error GoTo ErrorHandler
 
    Dim oHttp As New MSXML2.XMLHTTP30
 
    oHttp.Open "HEAD", strUrl, False
    oHttp.send
 
    GetResult = oHttp.Status & " " & oHttp.statusText
 
    Exit Function
 
ErrorHandler:
    GetResult = "Error: " & Err.Description
 
End Function
 
Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A2:A1000")
End Function

Thank you in advance for your help!
Todd

 

[Jerry Sullivan]

Hi Todd and Welcome to the Board,

You might try using WinHTTP instead of XMLHTTP.

Since I don't have your ISP, I'm not able to test exactly how to differentiate bad link redirects from redirects like http://www.microsoft.com ---> http://www.microsoft.com/en-us/default.aspx

Hopefully this will point you in the direction of a solution.

Add reference to Microsoft WinHTTP Services, version 5.1

Private Function GetResult(strURL As String) As String
    Dim oURL As New WinHttpRequest
     
    On Error GoTo ErrorHandler
     
    With oURL
        .Option(WinHttpRequestOption_EnableRedirects) = False
        .Open "POST", strURL, False
        .send ("")
        GetResult = .Status
        Exit Function
    End With
     
ErrorHandler:
   GetResult = "Error: " & Err.Description
    
End Function