MS Access VBA批量复制文件 长路径报错及目录结构迁移问题求解

• 现有VBA脚本可从Access表读取存储的源文件路径字段，批量将文件复制到指定目标目录
• 异常表现：路径总长度小于259字符时复制流程正常，超过该长度时脚本直接报错中断
• 待开发需求：复制文件时自动匹配源文件的原始目录层级，在目标目录下创建对应的子文件夹结构

Scripting.FileSystemObject 默认遵循Windows系统传统的260字符路径上限（MAX_PATH），未启用长路径兼容的情况下，所有长度超出阈值的路径IO操作都会触发系统层面的调用失败，不属于脚本逻辑bug。

长路径兼容处理 #

• 对所有传入FSO的路径字符串增加 \\?\ 前缀，即可绕过260字符的长度限制，最大支持32767字符的绝对路径访问
• 该方案不需要修改Windows系统的长路径开关注册表，兼容Win7及以上所有版本系统
• 注意：加该前缀的路径必须为无相对路径符号的绝对路径，不能包含.、..这类相对路径标识符

目录层级映射逻辑 #

• 读取每条记录的源文件完整路径时，提取对应的目录层级
• 拼接目标目录时逐段校验文件夹是否存在，缺失的层级自动递归创建，不需要预先硬编码目录结构

Sub CopyFilesFromTable2()
    On Error GoTo ErrorHandler
    Dim source As String
    Dim destRoot As String
    Dim fso As New FileSystemObject
    Dim SQL As String
    Dim RS As DAO.Recordset
    Dim db As DAO.Database
    Dim targetFolderPath As String
    
    ' 按需切换测试/生产表
    SQL = "select * from file_test"
    'SQL = "select * from file"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set db = CurrentDb
    Set RS = db.OpenRecordset(SQL)
    
    destRoot = "D:\Temp\Test\"
    ' 自动补目标根路径末尾的反斜杠，避免路径拼接错误
    If Right(destRoot, 1) <> "\" Then destRoot = destRoot & "\"
    
    ' 空记录集直接退出
    If RS.BOF And RS.EOF Then
        MsgBox "表中无待复制的文件记录"
        GoTo ExitSub
    End If
    
    RS.MoveFirst
    Do While Not RS.EOF
        ' 读取单条记录的源文件路径，加\\?\前缀兼容长路径
        source = "\\?\" & RS!LocalFile
        ' 提取源文件所在的目录层级，拼接对应目标路径
        ' 跳过源路径开头的磁盘号部分，保留完整的目录结构映射到目标根目录下
        targetFolderPath = destRoot & Mid(fso.GetParentFolderName(source), 4)
        ' 递归创建目标路径下所有缺失的文件夹
        Call CreateDeepFolder(fso, targetFolderPath)
        ' 复制文件到对应目标文件夹，覆盖同名旧文件
        fso.CopyFile source, targetFolderPath & "\" & fso.GetFileName(source), True
        RS.MoveNext
    Loop
    
ExitSub:
    On Error Resume Next
    RS.Close
    Set RS = Nothing
    Set db = Nothing
    Set fso = Nothing
    MsgBox "操作完成"
    Exit Sub
    
ErrorHandler:
    MsgBox "错误码：" & Err.Number & "，错误描述：" & Err.Description, vbCritical
    Resume ExitSub
End Sub

' 辅助函数：递归创建多层级文件夹
Function CreateDeepFolder(fso As FileSystemObject, folderPath As String)
    ' 文件夹已存在则直接返回
    If fso.FolderExists(folderPath) Then Exit Function
    ' 不存在则先递归创建父级目录
    CreateDeepFolder fso, fso.GetParentFolderName(folderPath)
    ' 创建当前层级目录
    fso.CreateFolder folderPath
End Function

• 移除原脚本中提前取首条记录路径、无意义的Dir调用、记录集指针来回跳转的冗余逻辑
• 修复空记录集场景下的字段引用越界报错问题
• 增加长路径兼容处理，解决259字符长度限制导致的复制失败问题
• 内置递归建目录的辅助函数，自动完成源目录层级到目标目录的结构映射
• 增加目标路径格式自动校验，避免斜杠缺失导致的拼接错误

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