totn Excel

MS Excel 2003: Extract hyperlink address (files and web addresses)

This Excel tutorial explains how to write a macro to extract both file and web hyperlink addresses in Excel 2003 and older versions (with screenshots and step-by-step instructions).

Question: In Microsoft Excel 2003/XP/2000/97, I have a spreadsheet that contains hyperlink addresses to files. I tried extracting the hyperlink address for these files, however I'm not getting the complete Address. The complete Address should be:

C:\My Documents\Past Projects\Centennial\Program Status Report.xls

But I only get:

\..\..\Past Projects\Centennial\Program Status Report.xls

Is there a way to always get the complete hyperlink address?

Microsoft Excel

Answer: Below are two functions that you can include in your spreadsheet to extract the complete hyperlink address for either a file or a web address.

Function HyperLinkText(pRange As Range) As String

   Dim ST1 As String
   Dim ST2 As String
   Dim LPath As String
   Dim ST1Local As String

   If pRange.Hyperlinks.Count = 0 Then
      Exit Function
   End If

   LPath = ThisWorkbook.FullName

   ST1 = pRange.Hyperlinks(1).Address
   ST2 = pRange.Hyperlinks(1).SubAddress

   If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then
      ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15)
   ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then
      ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12)
   ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then
      ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9)
   ElseIf Mid(ST1, 1, 6) = "..\..\" Then
      ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6)
   ElseIf Mid(ST1, 1, 3) = "..\" Then
      ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3)
   Else
      ST1Local = ST1
   End If

   If ST2 <> "" Then
      ST1Local = "[" & ST1Local & "]" & ST2
   End If

   HyperLinkText = ST1Local

End Function

Function ReturnPath(pAppPath As String, pCount As Integer) As String

   Dim LPos As Integer
   Dim LTotal As Integer
   Dim LLength As Integer

   LTotal = 0
   LLength = Len(pAppPath)

   Do Until LTotal = pCount + 1
      If Mid(pAppPath, LLength, 1) = "\" Then
         LTotal = LTotal + 1
      End If
      LLength = LLength - 1
   Loop

   ReturnPath = Mid(pAppPath, 1, LLength)

End Function

Then you can reference these new functions in your spreadsheet.

For example in cell B1, you could enter the following:

=HyperLinkText(A1)