Results 1 to 6 of 6

Thread: How to detect dead hyperlinks
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Sep 2010
    Location
    Vriezenveen, the Netherlands
    Posts
    22
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default How to detect dead hyperlinks

    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!

  2. #2
    Board Regular InaCell's Avatar
    Join Date
    Feb 2010
    Location
    Australia
    Posts
    189
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: How to detect dead hyperlinks

    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.

  3. #3
    New Member
    Join Date
    Sep 2010
    Location
    Vriezenveen, the Netherlands
    Posts
    22
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: How to detect dead hyperlinks

    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

  4. #4
    Board Regular InaCell's Avatar
    Join Date
    Feb 2010
    Location
    Australia
    Posts
    189
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Thumbs up Re: How to detect dead hyperlinks

    Hi

    Found one that appears to work.

    http://www.mrexcel.com/forum/excel-q...k-checker.html

    Code below, tested and worked for me.

    Code:
    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 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
    Cheers, InaCell.
    Last edited by InaCell; Mar 10th, 2015 at 06:34 PM.

  5. #5
    New Member
    Join Date
    Sep 2010
    Location
    Vriezenveen, the Netherlands
    Posts
    22
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: How to detect dead hyperlinks

    Thanks!!

    Works perfectly!

  6. #6
    Board Regular InaCell's Avatar
    Join Date
    Feb 2010
    Location
    Australia
    Posts
    189
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: How to detect dead hyperlinks

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •