如何通过VBA将库中多选文件夹批量复制到桌面指定文件夹？

实现步骤与代码 #

1. 先给Access添加必要引用

   • 打开VBA编辑器（按Alt+F11）→ 点击菜单栏「工具」→「引用」→ 勾选Microsoft Scripting Runtime并确定

2. 在按钮的点击事件中粘贴以下代码：

Private Sub cmdCopyFolders_Click()
    Dim rs As Recordset
    Dim fso As New FileSystemObject
    Dim destFolderPath As String
    Dim sourceFolderPath As String
    
    ' 定义桌面目标文件夹路径
    destFolderPath = Environ("USERPROFILE") & "\Desktop\Drafting Package"
    
    ' 自动创建目标文件夹（不存在时）
    If Not fso.FolderExists(destFolderPath) Then
        fso.CreateFolder destFolderPath
    End If
    
    ' 获取当前查询/窗体的记录集副本
    Set rs = Me.RecordsetClone
    rs.MoveFirst
    
    ' 遍历所有选中的记录
    Do Until rs.EOF
        If rs.Selected Then
            ' 提取当前记录的源文件夹路径
            sourceFolderPath = rs!Location
            
            ' 检查源文件夹是否存在，避免无效复制
            If fso.FolderExists(sourceFolderPath) Then
                ' 复制整个文件夹到目标路径，允许覆盖同名内容
                fso.CopyFolder sourceFolderPath, destFolderPath & "\", True
                Debug.Print "已完成复制: " & sourceFolderPath
            Else
                MsgBox "源文件夹不存在: " & sourceFolderPath, vbExclamation
            End If
        End If
        rs.MoveNext
    Loop
    
    ' 释放占用的资源
    Set rs = Nothing
    Set fso = Nothing
    
    MsgBox "批量复制完成！", vbInformation
End Sub

关键细节说明 #

• 选中记录识别：通过Me.RecordsetClone获取当前查询/窗体的记录集，用rs.Selected判断是否为用户选中的条目
• 路径适配：用Environ("USERPROFILE")自动获取当前用户桌面路径，避免硬编码导致的适配问题
• 文件夹复制逻辑：借助FileSystemObject.CopyFolder直接复制整个文件夹，第三个参数设为True表示覆盖已存在的同名文件或子文件夹
• 异常提示：增加源文件夹存在性检查，复制失败时会弹出提示告知具体问题

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