External Hyperlink Validation

LS2021

New Member
Joined
Feb 17, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
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
 
Last edited by a moderator:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
513
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Feb 17, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
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


1613653863614.png
 

LS2021

New Member
Joined
Feb 17, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
Hi Dan
I found the Issue I need to change the return information you had from "Status" to "URL" for the Null String query

1613658452557.png

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

New Member
Joined
Feb 17, 2021
Messages
7
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

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
1613674772186.png

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
HIJKLM
5YesABB Electromechanical lock Abb Dalton M31 EU Cert
6YesABB Dalton Fixing Kit 2ABB Dalton EU Cert
7YesABB dalton-tongue-a-for-front-entryABB Dalton EU Cert
8YesABB eva-general-code UL_Cert 20150728-E353291NRKH E353291ABB EVA Prox EU Cert
9YesABB EVA-unique-code Prox UL_Cert 20150728-E353291NRKH E353291ABB EVA Prox EU Cert
10YesABB Adam-ossd-info-m12-8-connector UL_Cert 20150728-E353291NRKH E353291ABB Adam OSSD EU Cert
11ABB 2TLA020053R4200
12ABB m12-c61-6m-cable-m12-5-female-connector
13ABB m12-c63-6m-cable-m12-8-female-conn
14YesABB Feed Block ZLS251ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
15YesABB Feed BLock ZLS252ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
16YesABB FEED BLOCK ZLS253ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
17YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
18YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
19YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
20YesABB Base Adaptor 32AABB Tech Cat NMTR.E222110ABB Buss Bar Accessories
21YesABB Base Adaptor 63AABB Tech Cat NMTR.E222110ABB Buss Bar Accessories
22ACME XF T2530134SXPTQ.E79947
23ACME XF T2530144SXPTQ.E79947
24ACME XF T2535153SXPTQ.E79947
25ACME XF T2535173SXPTQ.E79947
26ACME XF TF279262SXPTQ.E79947
27AB Solid-State RelaysAB Solid-State RelaysNMFT.E96956
28
29AB 1492-CABLE010ZNRAG.E10314.pdf
30YesAB 1492-td015_-en-p.pdfQVNU2.E65138.pdfAB 1492-J EU CERT6
31AB 1492-td015_-en-p.pdfIZLT.E34648.pdf
Sheet1
 
Last edited by a moderator:

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
513
Office Version
  1. 365
Platform
  1. Windows
Hi, sorry I'm only picking this up now. I'll take a look.
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
513
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
513
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Jul 11, 2018
Messages
513
Office Version
  1. 365
Platform
  1. Windows
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
HIJKLM
5YesABB Electromechanical lock Abb Dalton M31 EU Cert
6YesABB Dalton Fixing Kit 2ABB Dalton EU Cert
7YesABB dalton-tongue-a-for-front-entryABB Dalton EU Cert
8YesABB eva-general-codeUL_Cert 20150728-E353291NRKH E353291ABB EVA Prox EU Cert
9YesABB EVA-unique-code ProxUL_Cert 20150728-E353291NRKH E353291ABB EVA Prox EU Cert
10YesABB Adam-ossd-info-m12-8-connectorUL_Cert 20150728-E353291NRKH E353291ABB Adam OSSD EU Cert
11ABB 2TLA020053R4200
12ABB m12-c61-6m-cable-m12-5-female-connector
13ABB m12-c63-6m-cable-m12-8-female-conn
14YesABB Feed Block ZLS251ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
15YesABB Feed BLock ZLS252ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
16YesABB FEED BLOCK ZLS253ABB Tech Cat NMTR.E222110ABB Power Bar EU Cert50
17YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
18YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
19YesABB starter-pack-touch-proofABB Tech Cat NMTR.E222110ABB Starter pack EU Cert50
20YesABB Base Adaptor 32AABB Tech Cat NMTR.E222110ABB Buss Bar Accessories
21YesABB Base Adaptor 63AABB Tech Cat NMTR.E222110ABB Buss Bar Accessories
22ACME XF T2530134SXPTQ.E79947
23ACME XF T2530144SXPTQ.E79947
24ACME XF T2535153SXPTQ.E79947
25ACME XF T2535173SXPTQ.E79947
26ACME XF TF279262SXPTQ.E79947
27AB Solid-State RelaysAB Solid-State RelaysNMFT.E96956
28
29AB 1492-CABLE010ZNRAG.E10314.pdf
30YesAB 1492-td015_-en-p.pdfQVNU2.E65138.pdfAB 1492-J EU CERT6
31AB 1492-td015_-en-p.pdfIZLT.E34648.pdf
Sheet2
 

Forum statistics

Threads
1,136,290
Messages
5,674,886
Members
419,532
Latest member
longphamtel

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top