Option Explicit
Public Sub getAllHyperlinks()
Dim xSheet As Worksheet, refSheet As Worksheet, countSheet As Worksheet
Dim i As Integer
Dim xCell As Range
Dim sLink As String, xLink As String, sUrl As String
Dim strArray As Variant, xLinkArr As Variant, ArrOutput As Variant
Dim shp As Shape
If sheetExiste("référence externe") Then
Application.DisplayAlerts = False
On Error Resume Next
Application.ThisWorkbook.Worksheets("référence externe").Delete
On Error GoTo 0
Application.DisplayAlerts = True
End If
Set refSheet = Sheets.Add
With refSheet
.Name = ("référence externe")
.Range("A1").Resize(, 5).Value = Array("Cell value/shape name", "Localisation exacte: Workbook name & sheet name & col / row", "Hyperlinks référence/shape type", "Links: référence externe", "active or broken")
.Range("A1").Resize(, 5).Font.Name = "Times New Roman"
.Range("A1").Resize(, 5).Font.Color = RGB(48, 84, 150)
.Range("A1").Resize(, 5).Font.Size = 11
.Range("A1").Resize(, 5).HorizontalAlignment = xlCenter
.Range("A1").Resize(, 5).Interior.Color = RGB(242, 242, 242)
End With
i = 0
For Each countSheet In Application.ThisWorkbook.Worksheets
If countSheet.Name = refSheet.Name Then GoTo nextSheet:
countSheet.Select
Set xSheet = ActiveSheet
For Each xCell In xSheet.UsedRange
On Error Resume Next
sLink = xCell.Hyperlinks(1).SubAddress
If Err = 0 Then
If VBA.Left(xCell.Formula, 4) = "http" Or VBA.Left(xCell.Formula, 3) = "www" Then
refSheet.Range("A2").Offset(i, 0) = xCell.Value
refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
refSheet.Range("C2").Offset(i, 0) = "Url: " & xCell.Hyperlinks(1).Address
refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
sUrl = xCell.Formula
refSheet.Range("E2").Offset(i, 0) = checkUrl(sUrl)
i = i + 1
Else
refSheet.Range("A2").Offset(i, 0) = xCell.Value
refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
refSheet.Range("C2").Offset(i, 0) = xCell.Hyperlinks(1).Address
refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
refSheet.Range("E2").Offset(i, 0) = "'" & "???"
i = i + 1
End If
Else
If VBA.Left(xCell.Formula, 11) = "=HYPERLINK(" Then
strArray = VBA.Split(xCell.Formula, Chr(34))
refSheet.Range("A2").Offset(i, 0) = xCell.Value
refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
refSheet.Range("C2").Offset(i, 0) = strArray(1)
refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
xLink = VBA.Replace(xCell.Formula, "=HYPERLINK('", "")
ArrOutput = VBA.Split(xLink, "]")
xLink = ArrOutput(0)
xLink = VBA.Replace(xLink, "[", "")
If Not FileExists(xLink) = True Then refSheet.Range("E2").Offset(i, 0) = "Broken link" Else refSheet.Range("E2").Offset(i, 0) = "Active link"
i = i + 1
End If
End If
On Error GoTo 0
Next xCell
For Each shp In xSheet.Shapes
xLink = ""
On Error Resume Next
xLink = shp.Hyperlink.Address
On Error GoTo 0
If xLink <> "" Then
refSheet.Range("A2").Offset(i, 0) = "shape name: " & shp.Name
refSheet.Range("B2").Offset(i, 0) = "[" & Application.ThisWorkbook.Name & "]" & xSheet.Name & "; shape top: " & shp.Top & "; shape left: " & shp.Left
refSheet.Range("C2").Offset(i, 0) = "shape info.: type: " & determineShapeType(shp.Type)
refSheet.Range("D2").Offset(i, 0) = xLink
refSheet.Range("E2").Offset(i, 0) = "'" & "???"
i = i + 1
End If
Next shp
nextSheet:
Next countSheet
refSheet.Columns("A:E").AutoFit
refSheet.Select
If Not refSheet Is Nothing Then Set refSheet = Nothing
If Not xSheet Is Nothing Then Set xSheet = Nothing
End Sub
Private Function sheetExiste(sheetName As String) As Boolean
Dim i As Integer
sheetExiste = False
For i = 1 To Application.ActiveWorkbook.Sheets.Count
If Application.ActiveWorkbook.Sheets(i).Name = sheetName Then
sheetExiste = True
Exit For
End If
Next
End Function
Private Function FileExists(FilePath As String) As Boolean
Dim str As String
str = ""
On Error Resume Next
str = Dir(FilePath)
On Error GoTo 0
If str = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
Private Function determineShapeType(shpType As MsoShapeType) As String
Select Case shpType
Case "-2"
determineShapeType = "Mixed shape type"
Case 1
determineShapeType = "AutoShape"
Case 2
determineShapeType = "Callout"
Case 3
determineShapeType = "Chart"
Case 4
determineShapeType = "Comment"
Case 5
determineShapeType = "FreeForm"
Case 6
determineShapeType = "Group"
Case 7
determineShapeType = "Embedded OLE object"
Case 8
determineShapeType = "Form Control"
Case 9
determineShapeType = "Line"
Case 10
determineShapeType = "Linked OLE object"
Case 11
determineShapeType = "Linked Picture"
Case 12
determineShapeType = "OLE Control object"
Case 13
determineShapeType = "Picture"
Case 14
determineShapeType = "Placeholder"
Case 15
determineShapeType = "Text effect"
Case 16
determineShapeType = "Media"
Case 17
determineShapeType = "Text box"
Case 18
determineShapeType = "Script anchor"
Case 19
determineShapeType = "Table"
Case 20
determineShapeType = "Canvas"
Case 21
determineShapeType = "Diagram"
Case 22
determineShapeType = "Ink"
Case 22
determineShapeType = "Ink"
Case 23
determineShapeType = "Ink comment"
Case 24
determineShapeType = "SmartArt graphic"
Case 26
determineShapeType = "Web video"
Case 27
determineShapeType = "Content Office Add-in"
Case 28
determineShapeType = "Graphic"
Case 29
determineShapeType = "Linked graphic"
Case 30
determineShapeType = "3D model"
Case 31
determineShapeType = "Linked 3D model"
Case Else
determineShapeType = "¿unknown?"
End Select
End Function
Private Function checkUrl(xUrl As String) As String
Dim xDetermine As Object
Dim feedback As Variant
checkUrl = "Url is Broken"
On Error GoTo resumeOut:
Set xDetermine = CreateObject("WinHttp.WinHttpRequest.5.1")
With Request
.Open "GET", xUrl, False
.Send
feedback = .StatusText
End With
If Not xDetermine Is Nothing Then Set xDetermine = Nothing
If feedback = "OK" Then checkUrl = "Url is Active"
Exit Function
resumeOut:
' Error: broken or not checked
End Function