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
              
              Next
              
              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)
              
              Next
              
              For ii = 0 To num_relative
              
                  new_relative(ii) = arr_relative(initial_relative + ii)
              
              Next
              
              getAbsolutePath = Join(new_thisbook, '\') & '\' & Join(new_relative, '\')
              
              
          '链接在同一工作目录内
          Else
          
              getAbsolutePath = ThisWorkbook.Path & '\' & relativepath
          
          End If
      
      End If
   
   End Function

   示例：

   

参考资料：

[1] VBA中的相对路径（https://www.jianshu.com/p/8c51c723d1d6）

[2] Python编程快速上手: 让繁琐工作自动化（https://github.com/Ibuki-Suika/Books-3/blob/master/Python/Python%E7%BC%96%E7%A8%8B%E5%BF%AB%E9%80%9F%E4%B8%8A%E6%89%8B%20%E8%AE%A9%E7%B9%81%E7%90%90%E5%B7%A5%E4%BD%9C%E8%87%AA%E5%8A%A8%E5%8C%96.pdf）

[3] READING AND WRITING FILES（https://automatetheboringstuff.com/2e/chapter9/）

[4] Excel Hyperlink Object Address Property only shows relative path（https://www.tek-tips.com/viewthread.cfm?qid=1107468）

[5] excelvba打开文件夹路径（http://www.officexr.com/c/56602.html）

[6] Join function（https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/join-function）