List broken hyperlinks in Excel

BrokenLinks.bas

Option Explicit

Public Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Public Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY = 1

'''
''' Determine if specified file exists
'''
Public Function IsValidLink(path As String) As Boolean
    
    ' Setup FileSystem object
    Static FileSystem As Object
    If FileSystem Is Nothing Then: _
        Set FileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' Setup WinHttpRequest object
    ' https://docs.microsoft.com/en-us/windows/desktop/WinHttp/winhttprequest
    Static WinHttpRequest As Object
    If WinHttpRequest Is Nothing Then: _
        Set WinHttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        
    ' Credentials
    Static Username As String
    Static Password As String
    
    If Left(path, 2) = ".." Then ' Test relative path
        IsValidLink = FileSystem.FileExists(ActiveWorkbook.path & "/" & path)
    ElseIf StrComp(Left(path, 7), "http://", vbTextCompare) = 0 Or StrComp(Left(path, 8), "https://") = 0 Then ' Test URL
        WinHttpRequest.Open "GET", path, False ' False opens in synchronous mode
        WinHttpRequest.Send
        If WinHttpRequest.Status = 401 Then ' Server wants credentials
            If Username = "" And Password = "" Then
                Username = InputBox("Enter username:", path)
                Password = InputBox("Enter password:", path)
            End If
            WinHttpRequest.SetCredentials Username, Password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
            WinHttpRequest.Send
        End If
        IsValidLink = WinHttpRequest.Status = 200
    Else ' Check full path
        IsValidLink = FileSystem.FileExists(path)
    End If
    
End Function

'''
''' Enumerate through all hyperlinks in the ActiveSheet's UsedRange,
''' Print to immediate (Debug) window, if the file does not exist.
'''
Public Sub BeoknLinks()

    Dim cell As Range, link As Hyperlink, tmp As String
    
    For Each cell In ActiveSheet.UsedRange.Cells
        If cell.Hyperlinks.Count > 0 Then
            For Each link In cell.Hyperlinks
                Application.StatusBar = "Checking hyperlink: " & link.Address
                If Not IsValidLink(link.Address) Then
                    cell.Interior.Color = vbRed
                    cell.Font.Color = vbWhite
                    Debug.Print "Link for cell " & cell.Address & " is broken."
                    Debug.Print vbTab & link.Address
                End If
                DoEvents
            Next link
        End If
    Next cell
    
    Application.StatusBar = ""

End Sub