How to test hyperlinks validity?

[Eawyne]

Hi all

I have a workbook that's used as a dashboard : there are macros, buttons, icons, organized in a fancy way to appeal to the average user. It happens to have a lot of links for convenience to various files on the servers (C:, W:, etc.).

It also happens that most of those files get edited by random people, and so I wanted to try and tinker something that could test out the validity of hyperlinks from the dashboard to have a quick glance at any broken link that may need assistance.

I've come up with a few codes :

Sub TestHLinkValidity()

 
Dim rRng As Range
 Dim fsoFSO As Object
 Dim strFullPath As String
 Dim cCell As Range

 
Range("A1:B30").Select

 
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
 Set rRng = Selection

 
For Each cCell In rRng.Cells
 If cCell.Hyperlinks.Count > 0 Then
 
 strFullPath = ActiveWorkbook.Path & "\" & cCell.Hyperlinks(1).address
 If fsoFSO.FileExists(strFullPath) = False Then
 cCell.Interior.ColorIndex = 3
 Else
 cCell.Interior.ColorIndex = 0
 
 End If
 End If
 
 Next cCell

 
End Sub

and

Function HyperTest(c As Range)

 
If Dir(c) <> "" Then
 HyperTest = "File exists."

 
Else
 HyperTest = "File doesn't exist."
 
 End If

 
End Function

But the problem with those is that they require a well-formated list to be of any use. I don't have that luxury - unless I create a table that collects all links - which would require the manual intervention of any user that modifies a file ! Realistically, it wouldn't even happen in an utopia...

Is there a solution to my problem ? Does something exist that sorta scans the whole workbook for links and tests them out ? Isn't it too outlandish ?

 

[johnnyL]

What address range are your hyper links located?

Might also want to check out hyperlink check

 

[Eawyne]

There's no real range : only a few links are set in cells ; the rest's through buttons and macros

 

[GWteB]

See if this works for you. All members of all existing hyperlinks of the workbook in which this code is running are collected and displayed on a separate sheet.

Public Sub CollectHyperlinks()

    Dim Sht As Worksheet, Hl As Hyperlink, FSO As Object
    Dim arr() As Variant, i As Long, Anchor As Object
    Dim FileMsg As String, AnchorMsg As String
    
    ReDim arr(1 To 1000, 1 To 9)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    i = 1
    arr(i, 1) = "Worksheet"
    arr(i, 2) = "Hyperlink Anchor"
    arr(i, 3) = "File"
    arr(i, 4) = "Hyperlink Name"
    arr(i, 5) = "Hyperlink Address"
    arr(i, 6) = "SubAddress"
    arr(i, 7) = "ScreenTip"
    arr(i, 8) = "TextToDisplay"
    arr(i, 9) = "EmailSubject"
    
    For Each Sht In ThisWorkbook.Worksheets
        For Each Hl In Sht.Hyperlinks
            Set Anchor = Nothing
            AnchorMsg = ""
            FileMsg = ""
            With Hl
                If FSO.FileExists(.Address) Then FileMsg = "Exists"
                On Error Resume Next
                Set Anchor = .Range
                If Not Anchor Is Nothing Then
                    AnchorMsg = Anchor.Address
                Else
                    Set Anchor = .Shape
                    If Not Anchor Is Nothing Then
                        AnchorMsg = Anchor.Name
                    End If
                End If
                i = i + 1
                arr(i, 1) = Sht.Name
                arr(i, 2) = AnchorMsg
                arr(i, 3) = FileMsg
                arr(i, 4) = .Name
                arr(i, 5) = .Address
                arr(i, 6) = .SubAddress
                arr(i, 7) = .ScreenTip
                arr(i, 8) = .TextToDisplay
                arr(i, 9) = .EmailSubject
                On Error GoTo 0
            End With
        Next Hl
    Next Sht
    Application.ScreenUpdating = False
    With Application.Workbooks.Add.Sheets(1)
        .Range("A2").Select
        ActiveWindow.FreezePanes = True
        With .Rows("1:1")
            .Interior.Color = 10837023
            .Font.Color = RGB(255, 255, 255)
            .Font.Bold = True
        End With
        .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Columns("A:I").Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[Eawyne]

See if this works for you. All members of all existing hyperlinks of the workbook in which this code is running are collected and displayed on a separate sheet.

Public Sub CollectHyperlinks()

    Dim Sht As Worksheet, Hl As Hyperlink, FSO As Object
    Dim arr() As Variant, i As Long, Anchor As Object
    Dim FileMsg As String, AnchorMsg As String
   
    ReDim arr(1 To 1000, 1 To 9)
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    i = 1
    arr(i, 1) = "Worksheet"
    arr(i, 2) = "Hyperlink Anchor"
    arr(i, 3) = "File"
    arr(i, 4) = "Hyperlink Name"
    arr(i, 5) = "Hyperlink Address"
    arr(i, 6) = "SubAddress"
    arr(i, 7) = "ScreenTip"
    arr(i, 8) = "TextToDisplay"
    arr(i, 9) = "EmailSubject"
   
    For Each Sht In ThisWorkbook.Worksheets
        For Each Hl In Sht.Hyperlinks
            Set Anchor = Nothing
            AnchorMsg = ""
            FileMsg = ""
            With Hl
                If FSO.FileExists(.Address) Then FileMsg = "Exists"
                On Error Resume Next
                Set Anchor = .Range
                If Not Anchor Is Nothing Then
                    AnchorMsg = Anchor.Address
                Else
                    Set Anchor = .Shape
                    If Not Anchor Is Nothing Then
                        AnchorMsg = Anchor.Name
                    End If
                End If
                i = i + 1
                arr(i, 1) = Sht.Name
                arr(i, 2) = AnchorMsg
                arr(i, 3) = FileMsg
                arr(i, 4) = .Name
                arr(i, 5) = .Address
                arr(i, 6) = .SubAddress
                arr(i, 7) = .ScreenTip
                arr(i, 8) = .TextToDisplay
                arr(i, 9) = .EmailSubject
                On Error GoTo 0
            End With
        Next Hl
    Next Sht
    Application.ScreenUpdating = False
    With Application.Workbooks.Add.Sheets(1)
        .Range("A2").Select
        ActiveWindow.FreezePanes = True
        With .Rows("1:1")
            .Interior.Color = 10837023
            .Font.Color = RGB(255, 255, 255)
            .Font.Bold = True
        End With
        .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Columns("A:I").Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Amazing, it's exactly what I was looking for ! I'll have to toy around it a little to adapt it, but this is great ! Thanks a lot.

 

[GWteB]

You are welcome and thanks for the feedback

 

[Eawyne]

Due to work restrictions, I can't really send you the file as is - or at all, for that matter. So here's the code itself, without yours, untouched and working. You'd have to add a few phony links on Sheet1. Sorry to ask so much of you =/

Public Sub CollectHyperlinks()
    Dim Sht         As Worksheet, Hl As Hyperlink, FSO As Object
    Dim arr()       As Variant, i As Long, Anchor As Object
    Dim FileMsg     As String, AnchorMsg As String
    
    ReDim arr(1 To 1000, 1 To 9)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    i = 1
    arr(i, 1) = "Worksheet"
    arr(i, 2) = "Hyperlink Anchor"
    arr(i, 3) = "File"
    arr(i, 4) = "Hyperlink Name"
    arr(i, 5) = "Hyperlink Address"
    arr(i, 6) = "SubAddress"
    arr(i, 7) = "ScreenTip"
    arr(i, 8) = "TextToDisplay"
    arr(i, 9) = "EmailSubject"
    
    For Each Sht In ThisWorkbook.Worksheets
        For Each Hl In Sht.Hyperlinks
            Set Anchor = Nothing
            AnchorMsg = ""
            FileMsg = ""
            With Hl
                If FSO.FileExists(.Address) Then FileMsg = "Exists"
                On Error Resume Next
                Set Anchor = .Range
                If Not Anchor Is Nothing Then
                    AnchorMsg = Anchor.Address
                Else
                    Set Anchor = .Shape
                    If Not Anchor Is Nothing Then
                        AnchorMsg = Anchor.Name
                    End If
                End If
                i = i + 1
                arr(i, 1) = Sht.Name
                arr(i, 2) = AnchorMsg
                arr(i, 3) = FileMsg
                arr(i, 4) = .Name
                arr(i, 5) = .Address
                arr(i, 6) = .SubAddress
                arr(i, 7) = .ScreenTip
                arr(i, 8) = .TextToDisplay
                arr(i, 9) = .EmailSubject
                On Error GoTo 0
            End With
        Next Hl
    Next Sht
    Application.ScreenUpdating = FALSE
    With Application.Workbooks.Add.Sheets(1)
        .Range("A2").Select
        ActiveWindow.FreezePanes = TRUE
        With .Rows("1:1")
            .Interior.Color = 10837023
            .Font.Color = RGB(255, 255, 255)
            .Font.Bold = TRUE
        End With
        .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Columns("A:I").Columns.AutoFit
        
        'Trie les valeurs dans l'ordre alphabétique dans une colonne choisie - ici, D
        Range("C1") = "Index"
        Columns("A:C").Sort key1:=Range("C2"), order1:=xlAscending, Header:=xlYes
        
    End With
    Application.ScreenUpdating = TRUE
End Sub

 

[GWteB]

I'm unsure about your (additional?) query. Can you elaborate and be more specific about what you want?

 

[Eawyne]

I'm unsure about your (additional?) query. Can you elaborate and be more specific about what you want?

Argl, I posted that message in the wrong topic You may of course disregard it entirely !

 

[GWteB]

Okay