External Hyperlink Validation

[LS2021]

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

' 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

 

[LS2021]

Yes this is correct and is working Great
I need to add some code to allow for Cell Selection
I tried this on a larger sample of code and it looks like nothing is going on, But I know there are thing happening I tried in step mode
Is there anyway to show something is doing something else it looks like code is stuck?
May be a msg box showing current Cell under test a Spinning wheel?
thank you for your help I still don't know what was change or how it works.
Again Thank you very much
this code has cut down 52hours of testing to 2hour
I will still need to fix broken link but at least I will know which ones to work on and
not try all of them

 

[Dan_W]

Hi
I'm glad it's working - that's a relief! I hope that the code for the cell selection is straightforward - unless there is something particularly tricky about your data set, it should be something like = Range("A1:Z100") or something like that, no?

You will be able to see the progress of the code in the Immediate Window, because that's where all the Debug.Print statement output to - but the end user wouldn't see that, so I appreciate it isn't helpful in that respect.

There are a few options you might want to consider:-

1. The StatusBar - the bar at the bottom left of the Excel window - can be used to relay information to the user, and you can make a small progress bar to give an up-to-date indication of progress. This site provides you with code on how to do it, along with an animation to demonstrate what it would look like.

2. A Progress Bar in a Userform - this works much like the status bar, but it is much prettier. Here is a easy guide on how to make one.

Either option would require the same approach to implementation - if it's not urgent I could give it some thought next week. In terms of your suggestion re: a message box or a spinning wheel. Strictly speaking a simple message will actual stop the code from running - so everything would pause until the user pressed 'ok' for the code to continue. There are ways around that - you could force the msgbox to close after a few seconds. And a spinning wheel looks nice but the only way I know to implement it would be to use the Webbrowser control and a few API calls, and things have a tendency of breaking and crashing Excel. Perhaps some of the more experienced forum members might have a view on that?

A cut of 52hrs to 2hrs is fantastic - well done. Two hours is still a long time, though, isn't it? How many URLs do you need to check? If there is need to cut it down further, I think there is likely scope for further optimisation of your code. Basically, anytime the code 'touches' the worksheet, it slows everything down - and this code 'touches' the worksheet a lot. Ideally:

1. the code would load the URL data into an "array" (i.e., into memory), and then;
2. you could get Excel apportion the total list of URLs into X groups;
3. create bots designed to test the URLs in its assigned group (not as difficult as it sounds);
4. the bots would report back to Excel if there are any broken links;
5. Excel would produce a list for you. If you still needed the cells to be coloured yellow, you could run conditional formatting over the list and over the original data set to highlight any duplicates.

I think that would speed things up, but it would really depend on the scale of the exercise (i.e., how often do you run this process?). I would add that, if you're not actually monitoring the Immediate Window to check progress, you should comment out the Debug.Print statements so that Excel ignores those lines, because they will be slowing down the code too.

Hope everything works ok. Do let me know if you have any problems with the code.

 

[LS2021]

Thanks for all your help I will try the User form approach to see how that looks first that sounds like best approach
Thanks again