Any code to validate external hyperlinks?

[Linesy1]

Hi,
I have a list of external (web) hyperlinks in an Excel worksheet which I need to validate.
I have looked for some code to check them, although have only found code to check internal (local network) links. Does anyone know of a good alternative solution?
Cheers,
Linesy

 

[Leith Ross]

Hello Linesy1,

This macro will return the server status code for the site being interrogated. You can select whether you want to enable page redirects from the given URL. The default setting is False. Additionally, the macro returns the page source text in a global (Public) variable named PageSource.

For a full listing and explanation of sever status codes Click Here

The macro "TestURLs" starts at cell "A1" on the ActiveSheet and goes down to last URL in the column. The status for each URL appears immediately to the right in column "B".

Copy this code and paste it into a new VBA module to your workbook's VBA project.

' Written: March 15, 2011
' Author:  Leith Ross

Public PageSource As String
Public httpRequest As Object

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)

  Const WinHttpRequestOption_UserAgentString = 0
  Const WinHttpRequestOption_EnableRedirects = 6
  
  
    On Error Resume Next
       Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
         If httpRequest Is Nothing Then
            Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
         End If
       Err.Clear
    On Error GoTo 0

    httpRequest.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects


  ' Clear any pervious web page source information
    PageSource = ""
    
        ' Add protocol if missing
          If InStr(1, URL, "://") = 0 Then
             URL = "http://" & URL
          End If

          'Launch the HTTP httpRequest synchronously
            On Error Resume Next
               httpRequest.Open "GET", URL, False
               If Err.Number <> 0 Then
                ' Handle connection errors
                  GetURLStatus = Err.Description
                  Err.Clear
                  Exit Function
               End If
            On Error GoTo 0
           
          ' Send the http httpRequest for server status
            On Error Resume Next
               httpRequest.Send
               httpRequest.WaitForResponse
               If Err.Number <> 0 Then
                ' Handle server errors
                  PageSource = "Error"
                  GetURLStatus = Err.Description
                  Err.Clear
              Else
                ' Show HTTP response info
                  GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
                ' Save the web page text
                  PageSource = httpRequest.responsetext
              End If
            On Error GoTo 0
            
End Function

Sub TestURLs()

  Dim Cell As Range
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
      
      Set Wks = ActiveSheet
      Set Rng = Wks.Range("A1")
      
      
          Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
          If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
          
          For Each Cell In Rng
            Cell.Offset(0, 1) = GetURLStatus(Cell)
          Next Cell
          
End Sub

 

[Linesy1]

Hi Leith Ross,

Many thanks, this worked a treat - now I just need to find the time to look into the broken links it has discovered!

Cheers,

Linesy1

 

[GoJakie]

Looks like a very old post but helpful though!
I tried this example and found that it gives the redirect status with this line
GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText (Example of the output "200 - OK")

Is there any way to get the redirected url (the new url the original url is directing to)?

 

[shg]

Function FinalURL(sURL As String) As String
  ' shg 2009, but surely derived from something similar
  ' Requires a reference to Microsoft WinHTTP Services

  Static oHTTP As WinHttpRequest

  If oHTTP Is Nothing Then Set oHTTP = New WinHttpRequest

  On Error GoTo Oops
  With oHTTP
    .Open "GET", sURL
    .Send

    Select Case .Status
      Case 200: FinalURL = .Option(1)
      Case 403: FinalURL = "Forbidden"
      Case 404: FinalURL = "Not Found"
      Case 410: FinalURL = "Gone"
      Case 503: FinalURL = "Service Unavailable"
      Case Else: FinalURL = False
    End Select
    Exit Function
  End With

Oops:
  FinalURL = False
End Function

 

[GoJakie]

Hey thanks...
.Option(1) is actually what i needed... felt like having some extra cheese and toppings with those additional status info.

Cheers!

 

[shg]

You're welcome.

 

[GoJakie]

Does WinHTTPRequest work only for redirects? If there is a url that outputs json object, can that url be get via WinHTTPRequest? I was trying something from a very long time for another question I posted but unable to get a solution myself or any reply from this board. Can you have a look at this? http://www.mrexcel.com/forum/excel-questions/810639-get-value-json-object.html