How to detect dead hyperlinks

[edtwiest]

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!

 

[InaCell]

Hi edtwiest,

I tried the following 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

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.

 

[edtwiest]

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

 

[InaCell]

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.

[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.

 

[edtwiest]

Thanks!!

Works perfectly!

 

[InaCell]

First line above should be on 2 separate lines to work.

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