Excel VBA生成CSV后压缩为ZIP文件为空问题求助

我之前也踩过这个坑！用Shell.Application的CopyHere把文件打包进ZIP时，经常会碰到ZIP为空的情况，核心原因是CopyHere是异步执行的——代码执行完了，但文件复制操作还没完成，所以最后得到空ZIP。另外还要确保你创建的ZIP文件本身是有效的，不是单纯的空文件。

第一步：确保NewZip函数生成有效的ZIP文件 #

很多人写的NewZip只是创建了一个空文件，但ZIP格式需要特定的文件头才能被Shell识别。正确的实现应该是这样：

Sub NewZip(sPath As String)
    ' 如果目标ZIP已存在，先删除
    If Dir(sPath) <> "" Then Kill sPath
    
    ' 创建带ZIP标识头的空文件，这是关键！
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

这段代码写入了ZIP文件的起始标识（PK\x05\x06），这样Shell才能识别它是一个有效的ZIP容器。

第二步：添加等待逻辑，确保复制完成 #

因为CopyHere是异步的，我们需要等待文件复制完成后再结束代码。可以通过监控ZIP内的文件数量变化来判断：

Sub ZipCSV(FilePathCSV As String, FilePathZip As String)
    ' 先创建有效的空ZIP
    NewZip FilePathZip
    
    Dim objShell As Object
    Dim zipNamespace As Object
    Dim initialFileCount As Integer
    
    Set objShell = CreateObject("Shell.Application")
    Set zipNamespace = objShell.Namespace(FilePathZip)
    
    ' 记录ZIP初始的文件数量（应该是0）
    initialFileCount = zipNamespace.Items.Count
    
    ' 执行复制操作
    zipNamespace.CopyHere FilePathCSV
    
    ' 等待复制完成，设置10秒超时避免死循环
    Dim startTime As Double
    startTime = Timer
    Do While zipNamespace.Items.Count = initialFileCount
        DoEvents ' 让系统处理后台的复制任务
        If Timer - startTime > 10 Then
            MsgBox "打包超时，请检查文件是否被占用"
            Exit Do
        End If
    Loop
    
    ' 释放对象
    Set zipNamespace = Nothing
    Set objShell = Nothing
End Sub

DoEvents的作用是让VBA暂时让出CPU控制权，让系统完成复制操作；超时设置则是防止因为文件被占用等异常情况导致无限循环。

额外注意事项 #

• 关闭CSV文件：在执行打包前，一定要确保生成的CSV文件已经完全关闭（比如关闭对应的文件号、Excel工作簿），如果文件被占用，CopyHere会默默失败，ZIP还是空的。
• 使用绝对路径：FilePathCSV和FilePathZip必须是完整的绝对路径（比如C:\Documents\data.csv），Shell.Application对相对路径的支持很差，容易找不到文件。
• 权限问题：避免将ZIP保存到系统目录（如C:\Windows），这类目录需要管理员权限，普通用户写入会失败。

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