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

Exploring

发布于 2022-09-20 14:38:47

3.4K0

发布于 2022-09-20 14:38:47

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

1 绝对路径和相对路径

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

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

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

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

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

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

2 函数编写

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

在同一工作目录内；
在同一个公共盘，不在同一工作目录内；
不在同一公共盘。如果单元格链接的是本工作簿内的单元格，则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

示例：http://mpvideo.qpic.cn/0bf2vaaaaaaagmajgtbqknqvbkgdacuaaaaa.f10002.mp4?dis_k=e9ae6347a820899e8e0fbafb206c0c1a&dis_t=1663655862&vid=wxv_2029727663875063809&format_id=10002&support_redirect=0&mmversion=false

参考资料：

[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）

本文参与腾讯云自媒体同步曝光计划，分享自微信公众号。

原始发表：2021-09-02，如有侵权请联系 cloudcommunity@tencent.com 删除

vba