如何修改Access VBA代码将多份Excel导出文件打包至用户桌面压缩包？

步骤说明 #

1. 固定导出路径：明确将Excel文件导出到当前用户桌面，避免弹出保存对话框，方便后续定位文件进行压缩。
2. 创建空ZIP包：利用Windows系统自带的Shell.Application对象，无需额外工具即可生成压缩包。
3. 批量压缩文件：将导出的三个Excel文件添加到ZIP包，完成后给出操作提示。

完整代码 #

Function ExportAndZipTables()
    On Error GoTo ErrorHandler
    
    ' 定义变量
    Dim desktopPath As String
    Dim zipPath As String
    Dim filePaths As Variant
    Dim i As Integer
    Dim shellApp As Object
    
    ' 获取当前用户桌面路径
    desktopPath = Environ("USERPROFILE") & "\Desktop\"
    
    ' 定义要导出的表名数组
    Dim tablesToExport As Variant
    tablesToExport = Array("UB_Donors", "UB_DonationHistory", "UB_DonationValues")
    
    ' 批量导出表到桌面Excel文件（自动覆盖已有文件）
    For i = LBound(tablesToExport) To UBound(tablesToExport)
        Dim excelFileName As String
        excelFileName = desktopPath & tablesToExport(i) & ".xlsx"
        DoCmd.OutputTo acOutputTable, tablesToExport(i), "ExcelWorkbook(*.xlsx)", excelFileName, True, , , acExportQualityPrint
    Next i
    
    ' 设置压缩包保存路径（桌面的DonationData.zip）
    zipPath = desktopPath & "DonationData.zip"
    
    ' 创建空的ZIP文件
    CreateEmptyZip zipPath
    
    ' 初始化Shell对象用于操作ZIP
    Set shellApp = CreateObject("Shell.Application")
    
    ' 定义要添加到ZIP的文件路径
    filePaths = Array( _
        desktopPath & "UB_Donors.xlsx", _
        desktopPath & "UB_DonationHistory.xlsx", _
        desktopPath & "UB_DonationValues.xlsx" _
    )
    
    ' 将文件添加到ZIP，等待系统完成复制（避免因延迟导致失败）
    For i = LBound(filePaths) To UBound(filePaths)
        If Dir(filePaths(i)) <> "" Then
            shellApp.Namespace(zipPath).CopyHere shellApp.Namespace(filePaths(i)).Items
            Application.Wait Now + TimeValue("00:00:02") ' 等待2秒，文件较大可延长时间
        End If
    Next i
    
    ' 提示操作完成
    MsgBox "导出并压缩完成！文件已保存到桌面：" & vbCrLf & zipPath
    
Cleanup:
    Set shellApp = Nothing
    Exit Function
    
ErrorHandler:
    MsgBox "操作出错：" & Err.Description
    Resume Cleanup
End Function

' 辅助函数：创建空ZIP文件（ZIP格式需要特定头部标识）
Sub CreateEmptyZip(zipFilePath As String)
    ' 若ZIP已存在则先删除
    If Dir(zipFilePath) <> "" Then
        Kill zipFilePath
    End If
    
    Dim fso As Object, zipFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set zipFile = fso.CreateTextFile(zipFilePath, True)
    ' 写入ZIP文件标准头部
    zipFile.Write Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    zipFile.Close
    
    Set zipFile = Nothing
    Set fso = Nothing
End Sub

额外说明 #

• 覆盖设置：DoCmd.OutputTo的第5个参数设为True，会自动覆盖桌面已存在的同名Excel文件，无需手动确认。
• 删除原Excel文件（可选）：如果不需要保留导出的Excel文件，可在压缩完成后添加以下代码批量删除：

  ' 批量删除原Excel文件
  For i = LBound(filePaths) To UBound(filePaths)
      If Dir(filePaths(i)) <> "" Then Kill filePaths(i)
  Next i
  

• 等待时间调整：如果导出的文件较大，可延长Application.Wait的时间（比如00:00:05表示等待5秒），确保文件完全写入后再压缩。

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