VBA: 获取单元格内超链接文件的绝对路径

文章背景： 在工作中，有时为了内容跳转的方便，会在单元格内设置 超链接 ，通过 Hyperlinks(1).Address ，得到的是超链接文件的 相对路径 。有时为了VBA代码的编写方便，需要使用的是链接文件的 绝对路径 。下面通过编写VBA函数，获取单元格内超链接文件的绝对路径。

1 绝对路径和相对路径

有两种方法指定一个文件路径。

• 绝对路径，总是从根文件夹开始。
• 相对路径，它相对于程序的当前工作目录。

对于点（.）和点点（..）文件夹，它们不是真正的文件夹，而是可以在路径中使用的特殊名称。单个的句点（“点”）用作文件夹目录名称时，是“这个目录”的缩写。两个句点（“点点”）的意思是父文件夹。

下图是一些文件和文件夹的例子。如果当前工作目录设置为 C:\bacon ，这些文件夹和文件的相对目录，就表示为下图所示的样子。

相对路径开始处的.\是可选的。例如，.\spam.txt和spam.txt指的是同一个文件。

回到VBA，通过 ThisWorkbook.Path ，可以获取当前工作簿所在工作目录的路径；通过 Hyperlinks(1).Address ，得到的是基于 ThisWorkbook.Path 的相对路径；通过 ThisWorkbook.Path 拼接 相对路径 ，可以得到目标文件的 绝对路径 。

2 函数编写

针对单元格内的 超链接 ，本文暂不考虑共享文件夹的情况，链接的文件可以分为以下三种情况：

1. 在同一工作目录内；
2. 在同一个公共盘，不在同一工作目录内；
3. 不在同一公共盘。 如果单元格链接的是本工作簿内的单元格，则 Hyperlinks(1).Address 得到的是空字符串。 相对路径转化为绝对路径的函数代码如下所示：

Function getAbsolutePath(target As Range) As String
   Dim relativepath As String, arr_thisbook() As String, arr_relative() As String
   Dim ii As Integer, num_thisbook As Integer, initial_relative As Integer, num_relative As Integer
   Dim new_thisbook() As String, new_relative() As String
   If target.Hyperlinks.Count = 0 Then
       getAbsolutePath = "无链接"
   ElseIf target.Hyperlinks.Count = 1 Then
       '获取相对路径
       relativepath = target.Hyperlinks(1).Address
       '链接在本工作簿内
       If relativepath = "" Then
           getAbsolutePath = "本工作簿内"
       '链接其他盘
       ElseIf Left(relativepath, 3) Like "?:\" Then
           '完整路径
           getAbsolutePath = relativepath
       '链接在同一个盘，不在同一工作目录内
       ElseIf Left(relativepath, 3) Like "..\" Then
           arr_thisbook = Split(ThisWorkbook.Path, "\")
           num_thisbook = UBound(arr_thisbook)
           arr_relative = Split(relativepath, "\")
           initial_relative = 0
           num_relative = UBound(arr_relative)
           For ii = 0 To UBound(arr_relative)
               If arr_relative(ii) = ".." Then
                   num_thisbook = num_thisbook - 1
                   initial_relative = initial_relative + 1
                   num_relative = num_relative - 1
               End If
           ReDim new_thisbook(0 To num_thisbook)
           ReDim new_relative(0 To num_relative)
           For ii = 0 To num_thisbook
               new_thisbook(ii) = arr_thisbook(ii)
           For ii = 0 To num_relative
               new_relative(ii) = arr_relative(initial_relative + ii)
           getAbsolutePath = Join(new_thisbook, "\") & "\" & Join(new_relative, "\")
       '链接在同一工作目录内
           getAbsolutePath = ThisWorkbook.Path & "\" & relativepath
       End If