Option Explicit
Private Type udtHttpInfo
'--to facilitate passing http data btwn procedures
Domain As String
Location As String
StatusCode As Long
URL As String
End Type
Sub FixHyperlinks()
'--steps through each hyperlink object in the activesheet and takes
' action on hyperlinks identified as having bad urls
' (a non-existent domain url) or urls that are permanently redirected.
Dim hyp As Hyperlink
Dim lNdxHyp As Long, lCountHyp As Long
Dim sAddr As String, sLocation As String
Dim sNXDomainRedirect As String, sFinalURL_Domain As String
Dim uInfoFromRequest As udtHttpInfo
Dim uInfoFromNavigate As udtHttpInfo
'--validate user has connection to internet
If Not bIsConnected() Then
MsgBox "You must be connected to the Internet to run FixHyperlinks."
GoTo ExitProc
End If
Application.EnableEvents = False
lCountHyp = ActiveSheet.Hyperlinks.Count
For Each hyp In ActiveSheet.Hyperlinks
DoEvents
lNdxHyp = 1 + lNdxHyp
'--display progres
Application.StatusBar = "Processing Hyperlink: " _
& lNdxHyp & " of " & lCountHyp
sAddr = hyp.Address
'--limit process to addresses starting with http
If Len(sAddr) And LCase$(Left(sAddr, 4)) = "http" Then
'--get status and location using WinHttpRequest
uInfoFromRequest = uGetHttpInfoFromRequest(sURL:=sAddr)
Select Case uInfoFromRequest.StatusCode
Case 200
'--no redirects-do nothing
Case 300, 302, 307
'--temporary or multiple redirects. do nothing
Case 301
'--permanent redirection-update hyperlink address
Call UpdateHyperlink(hyp:=hyp, sAction:="UpdateAddress", _
sNewAddress:=uInfoFromRequest.Location)
Case 0
'--errored while connecting to url. retry with additional tests
If Not bIsConnected() Then
MsgBox "Connection to Internet was lost."
GoTo ExitProc
'--if can get site using IE and it isn't ISP NXURL, update hyperlink, else mark bad
Else
uInfoFromNavigate = uGetHttpInfoFromNavigation(sURL:=sAddr)
If Len(uInfoFromNavigate.Domain) = 0 Then
'--no domain found
Call UpdateHyperlink(hyp:=hyp, sAction:="MarkAsBad")
Else
'--only get ISP redirect domain if null string
If Len(sNXDomainRedirect) = 0 Then
sNXDomainRedirect = sGetNXDomainRedirect()
End If
If LCase$(uInfoFromNavigate.Domain) = LCase$(sNXDomainRedirect) Then
'--ISP redirected to default for non-existent domain
Call UpdateHyperlink(hyp:=hyp, sAction:="MarkAsBad")
Else
'--assume legitimate redirection
Call UpdateHyperlink(hyp:=hyp, sAction:="UpdateAddress", _
sNewAddress:=uInfoFromNavigate.URL)
End If
End If
End If
Case Else
'--mark as possible bad link
Call UpdateHyperlink(hyp:=hyp, sAction:="MarkAsPossiblyBad")
End Select
End If
Next hyp
ExitProc:
On Error Resume Next
Application.EnableEvents = True
Application.StatusBar = False
Exit Sub
ErrProc:
MsgBox Err.Number & ": " & Err.Description
Resume ExitProc
End Sub
Private Function uGetHttpInfoFromRequest(ByVal sURL As String) As udtHttpInfo
'--uses a winhttprequest to return udt with status and location properties
Dim lStatus As Long, lCounter As Long
Dim oRequest As Object
Dim uReturn As udtHttpInfo
Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error GoTo ExitProc
With oRequest
.Option(6) = False 'Disable Redirects
.Open "GET", sURL, False
.Send
uReturn.StatusCode = .Status
lStatus = .Status
Select Case (lStatus \ 100)
Case 3
uReturn.Location = .GetResponseHeader("Location")
Case 2
'--confirm no ISP redirect by checking HEAD
.Open "HEAD", sURL, False
.Send
If .Status <> lStatus Then
uReturn.StatusCode = 0
End If
Case Else
'no change to status from GET
End Select
End With
On Error GoTo 0
ExitProc:
uGetHttpInfoFromRequest = uReturn
End Function
Private Function uGetHttpInfoFromNavigation(sURL As String) As udtHttpInfo
'--uses a IE application to return udt with document properties of
' ultimate url reached by browser.
' only used for URLs that throw errors in winhttprequest
Dim lCounter As Long
Dim oIEapp As Object
Dim uReturn As udtHttpInfo
Set oIEapp = CreateObject("InternetExplorer.Application")
With oIEapp
.Navigate sURL
Do While .Busy
Loop
On Error Resume Next
If LCase$(.document.URL) <> LCase$(sURL) Then
uReturn.URL = .document.URL
uReturn.Domain = .document.Domain
End If
On Error GoTo 0
.Quit
End With
Set oIEapp = Nothing
uGetHttpInfoFromNavigation = uReturn
End Function
Private Function sGetNXDomainRedirect() As String
'--attempts to return the domain used to redirect non-existant
' domain urls. Used to distinguish legitimate redirects
' from ISP redirects or other hijacks
'--returns "NoRedirect" if the bogus url is not redirected.
Dim sReturn As String
Dim oIEapp As Object
Dim uTest As udtHttpInfo
Const sBOGUS_URL As String = _
"http://wwXYXw.NXDomainToTest"
Set oIEapp = CreateObject("InternetExplorer.Application")
With oIEapp
.Navigate sBOGUS_URL
Do While .Busy
Loop
On Error Resume Next
sReturn = .document.Domain
On Error GoTo 0
.Quit
End With
Set oIEapp = Nothing
If Len(sReturn) = 0 Then sReturn = "NoRedirect"
sGetNXDomainRedirect = sReturn
End Function
Private Function bIsConnected() As Boolean
'--tests if user is currently connected to the internet
' by sending httprequest.
Dim bReturn As Boolean
Dim oRequest As Object
Const sTEST_URL As String = "http://www.microsoft.com/"
Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error GoTo ExitProc
With oRequest
.Option(6) = True 'Enable Redirects
.Open "HEAD", sTEST_URL, False
.Send
bReturn = (.StatusText = "OK")
End With
ExitProc:
bIsConnected = bReturn
End Function
Private Function AddComment(cell As Range, sCmt As String, _
Optional bReplace As Boolean = False) As Boolean
' shg 2014
' Link to MrExcel.com post: http://tinyurl.com/oddgkm2
' Extends or replaces a cell comment
Dim iLen As Long
Dim i As Long
Dim sInp As String
' Case Len(sCmt) = 0 Comment is Nothing bReplace Delete Add Extend
' 0 F F F x
' 1 F F T x x x
' 2 F T F x x
' 3 F T T x x
' 4 T F F
' 5 T F T x
' 6 T T F
' 7 T T T
With cell(1)
If .Worksheet.ProtectContents And .Locked Then Exit Function
AddComment = True
Select Case -(4 * (Len(sCmt) = 0) + 2 * (.Comment Is Nothing) + bReplace)
Case 0
Case 1
.Comment.Delete
.AddComment
Case 2, 3
.AddComment
Case 4, 6, 7
Exit Function
Case 5
.Comment.Delete
Exit Function
End Select
With .Comment.Shape.TextFrame
' get the existing comment
sInp = .Characters(1, 255).Text
On Error Resume Next
Do
i = Len(sInp)
sInp = sInp & .Characters(i + 1, 255).Text
Loop While Len(sInp) > i
On Error GoTo 0
' catenate the new
sInp = sInp & IIf(Len(sInp), vbLf, "") & sCmt
iLen = Len(sInp)
' write it all out
For i = 1 To Len(sInp) Step 255
.Characters(i).Text = Mid(sInp, i, 255)
Next i
'.AutoSize = True
End With
End With
End Function
Private Sub UpdateHyperlink(ByVal hyp As Hyperlink, ByVal sAction As String, _
Optional ByVal sNewAddress As String)
'--used to define what actions are taken to update hyperlinks that are
' classified by calling procedure as:
' UpdateAddress, MarkAsPossiblyBad, or MarkAsBad.
'--this example shows optional code to color code the hyperlinks cells and
' or add cell comments.
Dim lColor As Long
Dim rHypRange As Range
Dim sNote As String, sOldAddress As String
sOldAddress = hyp.Address
If hyp.Type = msoHyperlinkRange Then
Set rHypRange = hyp.Range
End If
Select Case sAction
Case "UpdateAddress"
lColor = vbGreen
sNote = "Hyperlink address changed from: " & sOldAddress _
& " to: " & sNewAddress
'--change cell value if displaying old address
If LCase$(rHypRange.Value) = LCase$(sOldAddress) Then
rHypRange.Value = sNewAddress
End If
hyp.Address = sNewAddress
Case "MarkAsPossiblyBad"
lColor = vbYellow
sNote = "Hyperlink may be broken."
Case "MarkAsBad"
lColor = vbRed
sNote = "Broken Hyperlink deleted: " & sOldAddress
hyp.Delete
Case Else
Debug.Print "Unknown argument value in UpdateHyperlink"
End Select
'--Optional: Modify cell to document change
'--if type is range, change color and add comment
If Not rHypRange Is Nothing Then
If lColor Then rHypRange.Interior.Color = lColor
If Len(sNote) Then
AddComment cell:=rHypRange, sCmt:=Date & ": " & sNote, bReplace:=False
End If
Else
MsgBox sNote
End If
End Sub
