Results 1 to 4 of 4
  1. #1
    2 Star Lounger
    Join Date
    Feb 2001
    Posts
    109
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Eliminating Invalid HpyerLinks (XL 2000 SR1)

    Hello,

    I have several excel workbooks that will contain several broken hyperlinks per workbook. Is there any way to tell if a hyperlink is Invalid with vba?

    Thanks,

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts

    Re: Eliminating Invalid HpyerLinks (XL 2000 SR1)

    Try this code. It involves getting the complete hyperlink address (the majority of the code is a function I wrote to do this) and then searching for the path and name with filesearch. If not found it (as currently set up) will color the cell yellow.

    I have the code added to delete the hyperlink (keeps the contents in the cell) or you can use the clearcontents to just clear the cells contents.

    Steve

    <pre>Sub DeleteInvalidHL()
    Dim hl As Hyperlink
    For Each hl In ActiveSheet.Hyperlinks
    With Application.FileSearch
    .NewSearch
    .LookIn = GetFullHLAddress(hl, 1)
    .FileName = GetFullHLAddress(hl, 2)
    .MatchTextExactly = True
    If .Execute = 0 Then
    hl.Parent.Interior.Color = vbYellow
    'hl.Delete
    'hl.Parent.ClearContents
    End If
    End With
    Next
    End Sub

    Function GetFullHLAddress(hl As Hyperlink, Optional iType As Integer = 0)
    Dim sFilePath As String
    Dim sAddress As String
    Dim sHLPath As String
    Dim sHLFileName As String
    Dim AF As WorksheetFunction
    Dim iCountBacks As Integer

    Set AF = Application.WorksheetFunction

    sFilePath = hl.Parent.Parent.Parent.Path
    sAddress = hl.Address

    If InStr(sAddress, "") = 0 Then
    sHLPath = sFilePath & ""
    sHLFileName = sAddress
    Else
    sHLPath = sAddress
    sHLFileName = ""
    Do Until Right(sHLPath, 1) = ""
    sHLFileName = Right(sHLPath, 1) & sHLFileName
    sHLPath = Mid(sHLPath, 1, Len(sHLPath) - 1)
    Loop
    End If


    If InStr(sHLPath, ":") = 0 And InStr(sHLPath, "") = 0 Then
    iCountBacks = Len(sHLPath)
    sHLPath = AF.Substitute(sHLPath, "..", "")
    iCountBacks = (iCountBacks - Len(sHLPath)) / 3
    sHLPath = sFilePath & "" & sHLPath
    If iCountBacks > 0 Then _
    sHLPath = StripBacks(sHLPath, iCountBacks)
    End If

    Select Case iType
    Case 0
    GetFullHLAddress = sHLPath & sHLFileName
    Case 1
    GetFullHLAddress = sHLPath
    Case 2
    GetFullHLAddress = sHLFileName
    Case Else
    GetFullHLAddress = CVErr(xlErrNum)
    End Select
    End Function
    Function StripBacks(sPath As String, iNumBacks As Integer)
    Dim iCount As Integer
    StripBacks = sPath
    iCount = 0
    Do Until iCount = iNumBacks And Right(StripBacks, 1) = ""
    StripBacks = Mid(StripBacks, 1, Len(StripBacks) - 1)
    If Right(StripBacks, 1) = "" Then iCount = iCount + 1
    Loop
    End Function</pre>


  3. #3
    2 Star Lounger
    Join Date
    Feb 2001
    Posts
    109
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Eliminating Invalid HpyerLinks (XL 2000 SR1)

    Fantastic! Thank you very much. I will be testing it later this morning, but I was able to follow your code and I am sure it will work.

    Thanks again.

    Regards,

  4. #4
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts

    Re: Eliminating Invalid HpyerLinks (XL 2000 SR1)

    I recommend the "highlighting" in the testing stage. It is more easily "reversed" than deleting the hyperlink or clearing the contents. It also allows some investigation on what might be wrong. Many might be correctible by editing the hyperlinks (especially if folders have moved)

    Steve

Posting Permissions

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