Need script to detect broken Hyperlinks in Excel

[jryan3]

I have an Excel spreadsheet that contains more than 2000 hyperlinks. I am trying to write a VBA script that detects if any of the hyperlinks are broken.
Any suggestions?

Joe

 

[WalterContrata]

jryan3,

You can use for ... next to step through all of the hyperlinks in the worksheet.

Option Explicit

Sub CheckHyperlinks()
    Dim oWB As Workbook
    Set oWB = ActiveWorkbook
    
    Dim oFS As FileSystemObject
    Set oFS = New FileSystemObject
    
    Dim oSh As Worksheet
    Dim oHyp As Hyperlink
    Dim sAddress As String

    For Each oSh In oWB.Worksheets
       For Each oHyp In oSh.Hyperlinks

'CHECK WHETHER LINK IS BROKEN HERE          

       Next oHyp    
    Next oSh
    
    Set oHyp = Nothing
    Set oSh = Nothing
    Set oWB = Nothing
    Set oFS = Nothing

End Sub

I'm not sure what is the best way to "CHECK WHETHER LINK IS BROKEN", but maybe it depends on what kind of links you have. Perhaps you can set up an if ... else if ... else if ... end if block for the various types of link. For example, the following uses the File System Object to test whether a given file exists on the drive.

          sAddress = oHyp.Address

          If sAddress Like "http:*" Then

            'Add some code to check URL here

          Else

            If Not oFS.FileExists(sAddress) Then
                MsgBox "Broken link: " & sAddress
                'Deal with broken link
                'e.g. delete link or write info somewhere
            End If

          End If

but we have to come up with a way to deal with hyperlinks to URL's. For example, we could open a browser, point it to the URL, and figure out whether it found the URL. (I haven't checked, but I think that this is possible.)

Best Regards,
Walter

 

[CautionMP]

Joe,
I've been kicking this around since you originally posted the question. The following code will interate through a range of hyperlinks and load the page in a Internet Explorer window.
I have the same problem as Walter, how do you know if the page is valid. The IE object has a NavigateError event but I can't trap the event so here is a work around.
You can check the [tt]objIE.Document.Body.innerText[/tt] property of the loaded page for 'keys' that the page did not load correctly, i.e.:

If InStr(objIE.Document.Body.innerText, "The page could not be displayed") > 0 Then[green]
  'The link is not valid, flag the cell[/green]
  rowCurrent.Interior.Color = vbRed
End If

NOTE: On my computer using the following method did not cause the 'Search Page' in Internet explorer to be displayed so I could actually see the Error caused by the link.

[blue]Public Sub[/blue] CheckAllHyperlinks()
Dim objIE As Object
Dim rngHyperlinks As Range
Dim rowCurrent As Range
[green]
'Hard coded the column with the hyperlinks, used A1
'from the active sheet for this example[/green]
Set rngHyperlinks = ActiveSheet.Range("A1").CurrentRegion
[green]
'Spawn an IE window and make it visible[/green]
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
[green]
'Iterate through all the rows in the current region[/green]
For Each rowCurrent In rngHyperlinks.Rows
  objIE.Navigate rowCurrent.Hyperlinks(1).Address
  While objIE.Busy[green]
    'Wait until the page loads[/green]
  Wend[green]
  '***
  'Check if the page returned an error here, possible ways:
  ' Debug.Print objIE.Document.Body.innerText
  ' Debug.Print objIE.Document.Body.innerHTML
  '***
  
  'Pause execution so you can see what happened[/green][blue]
  Stop[/blue]
Next rowCurrent
[green]
'Close IE and release the object[/green]
objIE.Quit
Set objIE = Nothing
[green]
'Clean up[/green]
Set rowCurrent = Nothing
Set rngHyperlinks = Nothing
[blue]End Sub[/blue]

Hope this helps,
CMP

Instant programmer, just add coffee.

 

[niceguymattx]

I use the code below to do what you mentioned. It actually dowloads the URL to a temporary file, then tests if the file exists. If the file doesn't exist it it highlights the link and writes some details on a seperate sheet.

I havent vetted this code for workbook specific parts so it may require a quick look through.

'*****************requires link to scripting runtime library************************************
'********************** by Matt Whetton, 01 September 2005 *************************************
Option Explicit
'api declaration
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Sub TestAllHyperLinks(WS As Worksheet)
    Dim hp As Hyperlink, newWs As Worksheet, wkbk As Workbook, counter As Integer
    Dim HFlag As Boolean
    Set wkbk = WS.Parent
    Set newWs = wkbk.Sheets.Add
    counter = 1
    'this allows the user to specify if they want to have the cells highlighting that have
    'broken links
    If MsgBox("Do you want broken links highlighting?", vbYesNo) = vbYes Then HFlag = True
    For Each hp In WS.Hyperlinks
        If DoesURLExist(hp.Address) Then
            'yes it does, no action required
        Else
            'no it doesnt
            newWs.Cells(counter, 1) = hp.Name
            newWs.Cells(counter, 2) = hp.Address
            newWs.Cells(counter, 3) = hp.Range.Address
            If HFlag = True Then WS.Range(hp.Range.Address).Interior.ColorIndex = 3
            counter = counter + 1
        End If
    Next
End Sub
Private Function DoesURLExist(URL As String) As Boolean
    'function returns false also if url doesnt exist, but also deals with deleting the
    'temporary file created by DownloadFile function
    Dim fs As FileSystemObject, Temp101 As String
    Set fs = New FileSystemObject
    Temp101 = Environ("TEMP")
    'fs.CreateFolder (Temp101)
    If DownloadFile(URL, Temp101 & "\xxxx") = True Then
        DoesURLExist = True
        Kill Temp101 & "\xxxx"
    Else
        DoesURLExist = False
    End If
    'fs.DeleteFolder ("C:\temp101")
End Function
Private Function DownloadFile(URL As String, LocalFilename As String) As Boolean
    'function uses api to retrieve file and return false if doesnt complete
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    If lngRetVal = 0 Then DownloadFile = True
End Function

Cheers

Matt