在Access中使用VBA将绝对链接转换为相对链接的问题

要实现无论用户在什么位置都能访问报表，核心是基于Access数据库自身的位置生成相对路径，而非依赖固定工作目录或硬编码路径。以下是针对性的修改方案和代码：

关键优化点 #

• 动态获取当前Access数据库的存储路径作为主路径，避免硬编码带来的适配问题
• 生成相对于数据库路径的标准相对路径，确保整个目录移动后链接依然有效
• 调整数据库操作逻辑，避免循环内重复打开/关闭数据库，提升运行效率

修改后的完整代码 #

Sub Sample()
    Dim FileSystem As Object
    Dim HostFolder As String
    Dim dbPath As String
    
    ' 动态获取当前Access数据库的路径（作为主路径）
    dbPath = CurrentProject.Path
    If dbPath = "" Then
        MsgBox "请先将Access数据库保存到报表所在的基础目录", vbExclamation
        Exit Sub
    End If
    HostFolder = dbPath ' 主路径与数据库所在目录保持一致

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' 提前打开数据库和记录集，避免循环内重复操作
    Dim db As DAO.Database
    Set db = CurrentDb ' 使用当前打开的数据库，无需硬编码路径
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset("Tabelle1", dbOpenDynaset) ' 替换为你的实际表名

    DoFolder FileSystem.GetFolder(HostFolder), rs, FileSystem, dbPath

    ' 统一关闭资源
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set FileSystem = Nothing
    
    MsgBox "报表数据已同步完成", vbInformation
End Sub

Sub DoFolder(Folder As Object, rs As DAO.Recordset, fso As Object, basePath As String)
    Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder, rs, fso, basePath
    Next SubFolder
    
    Dim File As Object
    For Each File In Folder.Files
        ' 检查是否为PDF文件
        If LCase(fso.GetExtensionName(File.Name)) = "pdf" Then
            Dim pdfData As Variant
            ' 按约定格式拆分文件名：BerichtNr_Schlusswort_Datum_Titel_Autor.pdf
            pdfData = Split(File.Name, "_")
            
            If UBound(pdfData) >= 4 Then
                ' 生成相对于数据库路径的相对路径
                Dim relativePDFLink As String
                relativePDFLink = fso.GetRelativePath(basePath, File.Path)
                ' 兼容部分版本FileSystemObject的路径格式
                If Left(relativePDFLink, 2) <> ".\" Then
                    relativePDFLink = ".\" & relativePDFLink
                End If

                ' 从文件名提取数据
                Dim BerichtNr As String
                Dim Schlusswort As String
                Dim Datum As String
                Dim Titel As String
                Dim Autor As String
                BerichtNr = pdfData(0)
                Schlusswort = pdfData(1)
                Datum = Replace(pdfData(2), ".", "/")
                Autor = pdfData(3)
                Titel = pdfData(4)
                
                ' 插入数据到数据库表
                rs.AddNew
                rs("BerichteNr").Value = BerichtNr
                rs("Schlusswort").Value = Schlusswort
                rs("Datum").Value = Datum
                rs("Titel").Value = Titel
                rs("Autor").Value = Autor
                rs("PDFLink").Value = relativePDFLink
                rs.Update
            End If
        End If
    Next File
End Sub

使用说明 #

1. 保存数据库：将Access数据库文件保存到PDF报表所在的基础目录下
2. 替换表名：把代码中的Tabelle1修改为你的实际数据表名称
3. 运行宏：执行Sample宏，程序会自动遍历基础目录下的所有PDF，提取信息并插入相对路径
4. 打开报表：需要访问PDF时，用以下逻辑拼接完整路径：

   Dim fullPath As String
   fullPath = CurrentProject.Path & "\" & rs("PDFLink").Value
   ' 调用系统默认程序打开PDF
   Shell "explorer.exe """ & fullPath & """", vbNormalFocus
   

兼容处理 #

如果使用的FileSystemObject版本不支持GetRelativePath方法，可手动实现相对路径生成：

Function GetRelativePath(basePath As String, targetPath As String) As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim baseParts As Variant, targetParts As Variant
    baseParts = Split(fso.GetAbsolutePathName(basePath), "\")
    targetParts = Split(fso.GetAbsolutePathName(targetPath), "\")
    
    Dim i As Integer, commonLen As Integer
    commonLen = 0
    Do While i < UBound(baseParts) And i < UBound(targetParts) And baseParts(i) = targetParts(i)
        commonLen = commonLen + 1
        i = i + 1
    Loop
    
    Dim relative As String
    relative = String((UBound(baseParts) - commonLen), ".\")
    For i = commonLen To UBound(targetParts) - 1
        relative = relative & targetParts(i) & "\"
    Next i
    relative = relative & targetParts(UBound(targetParts))
    GetRelativePath = relative
End Function

内容的提问来源于stack exchange，提问作者Amine Fouassi