How to detect dead hyperlinks

edtwiest

New Member
Joined
Sep 1, 2010
Messages
31
Office Version
  1. 365
Platform
  1. Windows
Hello everybody,

Does anybody know if there is an UDf or a VBA-code to check if all the hyperlinks (webadresses) are still active?

I've seen some freeware, but at work we're not allowed to install anything, not even add-ins/ons....

so in cell A1 i have for example: Google and in cell b1 i want to know if the link in A1 is still aktive....
incell A2 i put in the value : www.edwintwiest.nl so in cell b2 i should get a text like "link is not aktive" or just an error....

I hope somebody can help me out.....

Thanks in advance!
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Hi edtwiest,

I tried the following code.

Code:
Private Const FLAG_ICC_FORCE_CONNECTION = &H1Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Sub Form_Load()
Dim myURL$
Dim i As Long
For i = 2 To 8
    myURL = Range("A" & i).Value
    On Error Resume Next
If InternetCheckConnection(myURL, FLAG_ICC_FORCE_CONNECTION, 0&) = 0 Then
MsgBox "Connection to " & myURL & " could not be made.", 48, "No Connection"
Else
MsgBox "Connection to " & myURL & " was successful.", 65, "Verified"
End If
Next i
End Sub
and
Code:
Private Const FLAG_ICC_FORCE_CONNECTION = &H1Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Sub CheckURL()
Dim myURL$
Dim i As Long


    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual


For i = 2 To 8
    myURL = Range("A" & i).Value
    On Error Resume Next


If InternetCheckConnection(myURL, FLAG_ICC_FORCE_CONNECTION, 0&) = 0 Then
Range("B" & i).Value = "Not Active"
Range("B" & i).Font.Color = vbRed
Else
Range("B" & i).Value = "Verified"
Range("B" & i).Font.Color = vbGreen
End If


Next i
MsgBox "Checks complete."
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Both check a range between A2 and A8.

Neither seem to work but they have been modified from code presented within this forum which did work.

Maybe you could play with it and get it to work.

Cheers, InaCell.
 
Upvote 0
Thank you InaCell!

The codes don't work on my worksheet aswell.... maybe another wizzkid is able to find the 'error' of correction to get a working code?
My knowledge of VBA is practicallly zero, but i will sure try to puzzle ;)
 
Upvote 0
Hi

Found one that appears to work.

http://www.mrexcel.com/forum/excel-questions/396511-hyperlink-checker.html

Code below, tested and worked for me.

Code:
[COLOR=#333333]Const scUserAgent = "API-Guide test program"[/COLOR]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 [COLOR=#417394]Hyperlink[/COLOR], 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 [COLOR=#417394]connection[/COLOR]
    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 
[COLOR=#333333]End Sub[/COLOR]

Cheers, InaCell.
 
Last edited:
Upvote 0
First line above should be on 2 separate lines to work.
Code:
Const scUserAgent = "API-Guide test program"
Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3, INTERNET_FLAG_RELOAD = &H80000000Private 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 test()
    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
    For Each hl In sh.Hyperlinks
        hl.Range.Interior.ColorIndex = 0
        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")
            hl.Range.Interior.Color = IIf(hFile <> 0, vbGreen, vbRed)
            InternetCloseHandle hFile: DoEvents
        End If
    Next
er:
    InternetCloseHandle hFile
    InternetCloseHandle hOpen  End Sub
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,273
Members
448,559
Latest member
MrPJ_Harper

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
Back
Top