Hyperlink checker

[rirus]

I have a spreadsheet that contains several hyperlinks to different support web pages. I would like to periodically check these links to verify they are still valid. Is there a way to do this using VBA code?


Thanks,

rirus

 

[EducatedFool]

Try

Const scUserAgent = "API-Guide test program"
Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3, INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Sub [B]test[/B]()
    Dim hl As Hyperlink, sh As Worksheet: Set sh = ActiveSheet
    Dim hOpen As Long, hFile As Long, sBuffer As String, Ret As Long
    sBuffer = Space(1000)    'Create a buffer for the file we're going to download
    'Create an internet connection
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

    On Error GoTo er
    [B]For Each hl In sh.Hyperlinks[/B]
        [B]hl.Range.Interior.ColorIndex = 0[/B]
        If hl.Address Like "http://*.*" Then
            hFile = InternetOpenUrl(hOpen, hl.Address, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)    'Open the url
            InternetReadFile hFile, sBuffer, 1000, Ret    'Read the first 1000 bytes of the file
            Debug.Print hl.Address, IIf(hFile <> 0, "available", "not valid")
           [B][COLOR="Red"] hl.Range.Interior.Color = IIf(hFile <> 0, vbGreen, vbred)[/COLOR][/B]
            InternetCloseHandle hFile: DoEvents
        End If
    [B]Next[/B]
er:
    InternetCloseHandle hFile
    InternetCloseHandle hOpen
End Sub

All of the available hyperlinks will be painted in green, not available - in red

 

[rirus]

link checker

I think I may have confused everyone with what I was needing. I said hyperlinks in a Worksheet, I meant links listed in a column not actual hyperlinks within a spreadsheet. Sorry EducatedFool for the confusion.

In Column A I have listed...

(A1) http://www.mrexcel.com/
(A2) http://www.microsoft.com/en/us/default.aspx
(A3) http://twitter.com/
(A4) http://www.linkedin.com/

and so on...

I am wanting to validate these links exist and that I can get to them. Preferrably, without opening a bunch of windows. I have thousnds I have to verify so doing it manually is out of the question.

Regards

rirus

 

[EducatedFool]

In Column A I have listed...

My macro is designed especially for checking hyperlinks like yours.

Run macro test to validate these links without opening a bunch of windows:

 

[rirus]

Ok, sorry again... my mistake.

I tried running the test with the links in Column A and they all showed up red, yet when I click on the actual link they opend to the page.

This was displayed in my immediate window in the VB editor:
http://www.mrexcel.com/ not valid
http://www.microsoft.com/en/us/default.aspx not valid
http://twitter.com/ not valid
http://www.linkedin.com/ not valid

Copied all the code and placed in Module1. Could it be a firewall issue?

rirus

 

[EducatedFool]

Send me your file to igor "dog" aztel.org

I'll try to fix the problem.

Could it be a firewall issue?

No.

I have to look at the file to determine the cause.
With my hyperlinks everything working properly

 

[EducatedFool]

Could it be a firewall issue?

Quite possibly.
Turn off the firewall, and then run the macro again.

In the future, create a rule for Microsoft Excel, and macro will work always

 

[TED54]

Is there anyway of making the above macro scan sharepoint links on a company web portal?

 

[newtech]

Hello,

I am trying to use your code, it is working fine, but I was wondering if you can help me make it show links that give " PAGE NOT FOUND" 404 - Page Not Found also highlighted in red ? currently its highlights them green

Try

Const scUserAgent = "API-Guide test program"
Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3, INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

Sub [B]test[/B]()
    Dim hl As Hyperlink, sh As Worksheet: Set sh = ActiveSheet
    Dim hOpen As Long, hFile As Long, sBuffer As String, Ret As Long
    sBuffer = Space(1000)    'Create a buffer for the file we're going to download
    'Create an internet connection
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

    On Error GoTo er
    [B]For Each hl In sh.Hyperlinks[/B]
        [B]hl.Range.Interior.ColorIndex = 0[/B]
        If hl.Address Like "http://*.*" Then
            hFile = InternetOpenUrl(hOpen, hl.Address, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)    'Open the url
            InternetReadFile hFile, sBuffer, 1000, Ret    'Read the first 1000 bytes of the file
            Debug.Print hl.Address, IIf(hFile <> 0, "available", "not valid")
           [B][COLOR=Red] hl.Range.Interior.Color = IIf(hFile <> 0, vbGreen, vbred)[/COLOR][/B]
            InternetCloseHandle hFile: DoEvents
        End If
    [B]Next[/B]
er:
    InternetCloseHandle hFile
    InternetCloseHandle hOpen
End Sub

All of the available hyperlinks will be painted in green, not available - in red