External Hyperlink Validation

LS2021 · Feb 17, 2021

Hello New to you site
I have a XLS file that has over 3,000 Hyperlink in 4 consecutive columns and the 3rd column requires you to log in to access information
the help i need is a way to access this files hyperlinks from a different excel file to test each of the links to see if they are valid with out opening each one manually to see that they are working
If they fail I'd like to turn that cell back ground Yellow
I have found this piece of code on your site but it will not work since it only looks at the Cell information and not at the Hyperlink address contained in cell also
I don't want my information over written in the next column and not sure how to modify the code below to get the results I'm looking for
Can you help

VBA Code:

' Written: April 29, 2012
' Author:  Leith Ross
' Summary: Returns the status for a URL along with the Page Source HTML text.

Public PageSource As String
Public httpRequest As Object

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

    Const WinHttpRequestOption_EnableRedirects = 6


        If httpRequest Is Nothing Then
            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
        End If

        ' Control if the URL being queried is allowed to redirect.
          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 ValidateURLs()

    Dim Cell As Range
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Status As String
    Dim Wks As Worksheet
  
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("i2")
      
        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
                Status = GetURLStatus(Cell)
                If Status <> "200 - OK" Then
                   'Cell = Status
                   Range(Cell).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .Color = 255
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
                End If
            Next Cell
      
End Sub

Dan_W · Feb 18, 2021

Hi. I tried playing with the code your provided, and the code below should work. I couldn't make sense of the original version's way of setting the target range, so I have just changed it to check only those cells in a selected area. You may want to change this.

It will first check to see whether or not the target cell has a hyperlink. If it does, it will take the destination address the hyperlink. If there is no hyperlink, it assumes that the URL will be the text in the cell, and uses that instead. Please try this on a dummy set of data before trying it on the real data set, out of an abundance of caution.

Let me know if it works.

VBA Code:

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)
        
    Dim PageSource As String
    
    Const WinHttpRequestOption_EnableRedirects = 6
    On Error Resume Next
    If httpRequest Is Nothing Then
        Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        If httpRequest Is Nothing Then Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
        Err.Clear
    End If

    On Error GoTo ErrHandler

    
    ' Control if the URL being queried is allowed to redirect.
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

    ' Launch the HTTP httpRequest synchronously
    httpRequest.Open "GET", URL, False
    
    ' Send the http httpRequest for server status
    httpRequest.Send
    httpRequest.WaitForResponse
    
    ' Show HTTP response info
    GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
    ' Save the web page text
    PageSource = httpRequest.ResponseText

ErrHandler:
    If Err.Number <> 0 Then
        ' Handle connection errors
        GetURLStatus = "Error: " & Err.Number & " - " & Err.Description
        Err.Clear
        Exit Function
    End If
    
End Function


Sub ValidateURLs()

    Dim Cll As Range
    Dim Status As String
    Dim URL As String
    
' You may want to change this.
    Set rng = Selection
    
    For Each Cll In rng
        URL = GetURL(Cll)
        If Status<>vbNullString then 
            Status = GetURLStatus(URL)
            If Status = "" Or InStr(Status, "Error") Then Cll.Interior.Color = vbYellow
        End If
    Next Cll

End Sub
Function GetURL(rng As Range)
    Dim tmpURL As String
    If rng.Hyperlinks.Count > 0 Then
        tmpURL = rng.Hyperlinks(1).Address
    Else
        tmpURL = rng.Value
    End If
    If tmpURL = vbNullString Then Exit Function
    If Left(tmpURL, 4) <> "http" And InStr(tmpURL, "://") = 0 Then tmpURL = "http://" & tmpURL

    GetURL = tmpURL
End Function

LS2021 · Feb 18, 2021

Hi Dan
Thanks for the response
But the code is not working
the Function "GetURL" is not returning any information back to the Sub "ValidaeURLs" at "Status" it is always a null String even though "tmpURL" and "GetURL" has correct valid information
I have not used function before so not sure what to change or how to pass the data between Sub and Functions

LS2021 · Feb 18, 2021

Hi Dan
I found the Issue I need to change the return information you had from "Status" to "URL" for the Null String query

the next issue i see is for what ever reason i have a good Hyperlink and in next function "GetURLStatus" It is returning a Fault 301 and is not moved instead of a code 200 OK
what would i need to change to get Just the actual fail code so that i could use something like If Status is greater then 200

LS2021 · Feb 18, 2021

Hi Dan
I have gotten most to work and filling in Boxes with color but I don't understand the Function "GetURLStatus" and Can't find Information
I would like to send you a small portion of my workbook so you could see what is going on I don't know if the cells that were highlight are still highlighted but this is what i got after running the code
Items in yellow should be working but reported as error 302 and not as 200 the items in column k require a log in but just show as 302 temp moved the items in orange should have failed and been red like the 3 others ones

Can you help Thanks

Here is the current code i modified to get the above to work

VBA Code:

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)
       
    Dim PageSource As String
   
    Const WinHttpRequestOption_EnableRedirects = 6
    On Error Resume Next
    If httpRequest Is Nothing Then
        Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        If httpRequest Is Nothing Then Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
        Err.Clear
    End If

    On Error GoTo ErrHandler

   
    ' Control if the URL being queried is allowed to redirect.
    httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

    ' Launch the HTTP httpRequest synchronously
    'httpRequest.Open "GET", URL, False
    httpRequest.Open "GET", URL, True
    ' Send the http httpRequest for server status
    httpRequest.Send
    httpRequest.WaitForResponse
   
    ' Show HTTP response info
    GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
    ' Save the web page text
    PageSource = httpRequest.ResponseText

ErrHandler:
    If Err.Number <> 0 Then
        ' Handle connection errors
        GetURLStatus = "Error: " & Err.Number & " - " & Err.Description
        Err.Clear
        Exit Function
    End If
   
End Function


Sub ValidateURLs()

    Dim Cll As Range
    Dim Status As String
    Dim URL As String
   
' You may want to change this.
    Set rng = Selection
   
    For Each Cll In rng
        URL = GetURL(Cll)
        If URL <> vbNullString Then
            Status = GetURLStatus(URL)
            'If Status = "" Or InStr(Status, "Error") Then Cll.Interior.Color = vbYellow
        'End If
            If Status = "" Or InStr(Status, "3") Then
                Cll.Interior.Color = vbYellow
           
            ElseIf Status = "" Or InStr(Status, "4") Then
                Cll.Interior.Color = vbRed
            End If
           
        End If
        Status = ""
        URL = ""
    Next Cll

End Sub
Function GetURL(rng As Range)
    Dim tmpURL As String
    If rng.Hyperlinks.Count > 0 Then
        tmpURL = rng.Hyperlinks(1).Address
    Else
        tmpURL = rng.Value
    End If
    If tmpURL = vbNullString Then Exit Function
    If Left(tmpURL, 4) <> "http" And InStr(tmpURL, "://") = 0 Then tmpURL = "http://" & tmpURL

    GetURL = tmpURL
End Function

Sample spread sheet

Component Viewer7 25-Oct-19.xlsx

H

I

J

K

L

M

5

Yes

ABB Electromechanical lock

Abb Dalton M31 EU Cert

6

Yes

ABB Dalton Fixing Kit 2

ABB Dalton EU Cert

7

Yes

ABB dalton-tongue-a-for-front-entry

ABB Dalton EU Cert

8

Yes

ABB eva-general-code

UL_Cert 20150728-E353291

NRKH E353291

ABB EVA Prox EU Cert

9

Yes

ABB EVA-unique-code Prox

UL_Cert 20150728-E353291

NRKH E353291

ABB EVA Prox EU Cert

10

Yes

ABB Adam-ossd-info-m12-8-connector

UL_Cert 20150728-E353291

NRKH E353291

ABB Adam OSSD EU Cert

11

ABB 2TLA020053R4200

12

ABB m12-c61-6m-cable-m12-5-female-connector

13

ABB m12-c63-6m-cable-m12-8-female-conn

14

Yes

ABB Feed Block ZLS251

ABB Tech Cat

NMTR.E222110

ABB Power Bar EU Cert

50

15

Yes

ABB Feed BLock ZLS252

ABB Tech Cat

NMTR.E222110

ABB Power Bar EU Cert

50

16

Yes

ABB FEED BLOCK ZLS253

ABB Tech Cat

NMTR.E222110

ABB Power Bar EU Cert

50

17

Yes

ABB starter-pack-touch-proof

ABB Tech Cat

NMTR.E222110

ABB Starter pack EU Cert

50

18

Yes

ABB starter-pack-touch-proof

ABB Tech Cat

NMTR.E222110

ABB Starter pack EU Cert

50

19

Yes

ABB starter-pack-touch-proof

ABB Tech Cat

NMTR.E222110

ABB Starter pack EU Cert

50

20

Yes

ABB Base Adaptor 32A

ABB Tech Cat

NMTR.E222110

ABB Buss Bar Accessories

21

Yes

ABB Base Adaptor 63A

ABB Tech Cat

NMTR.E222110

ABB Buss Bar Accessories

22

23

24

25

26

27

AB Solid-State Relays

NMFT.E96956

28

29

AB 1492-CABLE010Z

NRAG.E10314.pdf

30

Yes

AB 1492-td015_-en-p.pdf

QVNU2.E65138.pdf

AB 1492-J EU CERT

6

31

AB 1492-td015_-en-p.pdf

IZLT.E34648.pdf

Sheet1

Dan_W · Feb 22, 2021

Hi, sorry I'm only picking this up now. I'll take a look.

Dan_W · Feb 22, 2021

Hi - I just tried to send you a message - are you there?

LS2021 · Feb 22, 2021

Hello Dan
How can i help

Dan_W · Feb 24, 2021

Hi - so I've been checking the code (thank you for changing Status to URL, btw). It is helpful to now test the code against the actual data you intend to run it against.

I have made some changes to the code below, but in summary:

the status code 302 isn't an error - rather it's a notification from the server that the page/resource that had been at that URL has relocated. That being the case, I have put in code below which extracts from the servers notification (the ResponseHeaders) the new location of the page, and then tries to access the page at the new URL.
I have put DEBUG.PRINT statements throughout so that it can log the status of each URL checked.
If the response is not status code 200, it colours the cell yellow.

Admittedly, it isn't particularly elegant, but it does appear to work. I will post the results of my code for you in just a moment.

VBA Code:

Sub ValidateURLs()

    Dim Cll As Range
    Dim Status As String
    Dim URL As String
    
    ' You may want to change this.
    Set rng = Selection
    
    For Each Cll In rng
        DoEvents
        URL = GetURL(Cll)
        If URL <> "" Then
            Debug.Print vbNewLine & "Cell: " & Cll.Address & vbNewLine & "Extracted: " & URL
            Status = GetURLStatus(URL)
            Debug.Print "Status: " & Status
            If InStr(Status, "200") = 0 Then Cll.Interior.color = vbYellow
        End If
    Next Cll

End Sub
Function GetURL(rng As Range) As String
    
    Dim tmpURL As String
    If rng.Hyperlinks.Count > 0 Then
        tmpURL = rng.Hyperlinks(1).Address
    Else
        If InStr(LCase(rng.Value), "http") > 0 Then tmpURL = rng.Value
    End If

    GetURL = tmpURL
End Function

Public Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)
        
    Dim PageSource As String
    
    Const WinHttpRequestOption_EnableRedirects = 6
    On Error Resume Next
    If httprequest Is Nothing Then
        Set httprequest = CreateObject("WinHttp.WinHttpRequest.5.1")
        If httprequest Is Nothing Then Set httprequest = CreateObject("WinHttp.WinHttpRequest.5")
        Err.Clear
    End If

    On Error GoTo ErrHandler

    
    ' Control if the URL being queried is allowed to redirect.
    httprequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

    ' Launch the HTTP httpRequest synchronously
    httprequest.Open "GET", URL, False
    
    ' Send the httpRequest for server status
    httprequest.send
    httprequest.WaitForResponse
    
    Dim strNewURL As String, checkNewURL As String
    
    ' The following checks the HTTP response headers for
    ' the 'Location' header, which sets out the URL of the relocated resource.

    If InStr(httprequest.getAllResponseHeaders, "Location") Then
        strNewURL = httprequest.getResponseHeader("Location")
        Debug.Print "Redirected: " & strNewURL
        checkNewURL = GetURLStatus(strNewURL)
        GetURLStatus = checkNewURL
    Else
        GetURLStatus = httprequest.Status & " - " & httprequest.statusText
    End If
    Exit Function
ErrHandler:
    If Err.Number <> 0 Then
        ' Handle connection errors
        GetURLStatus = Err.Number & " - " & Err.Description
        Err.Clear
        Exit Function
    End If
    
End Function

Dan_W · Feb 24, 2021

This is the result of the code. L15 and L16 are not yellow because neither contain a URL nor are hyperlinked. All yellow cells in Column K link to a server that is down; the remainder (2 cells) link to a different domain.

Is this close to the correct result?

Book1