由 Excel VBA 创建的附加 zip 文件在尝试发送时打开

Question

我想发送一封带有附件的电子邮件。

我使用以下代码创建了一个 ZIP 文件夹：

Sub ZipFolder(folderToZipPath As Variant, zippedFileFullName As Variant)

    Dim ShellApp As Object
    
    'Create an empty zip file
    Open zippedFileFullName For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    
    'Copy the files & folders into the zip file
    Set ShellApp = CreateObject("Shell.Application")
    ShellApp.Namespace(zippedFileFullName).CopyHere ShellApp.Namespace(folderToZipPath).items
    
    'Zipping the files may take a while, create loop to pause the macro until zipping has finished.
    On Error Resume Next
    Do Until ShellApp.Namespace(zippedFileFullName).items.Count = ShellApp.Namespace(folderToZipPath).items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
    
End Sub

通过以下内容，我从 Outlook 收到附件仍处于打开状态的消息。我必须在它发送电子邮件之前手动确认。

会不会是宏创建的ZIP文件夹没有关闭？

' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(olMailItem)

    With objEmail
        .to = xxx
        .cc = xxx"
        .Subject = "subject"
        .Body = "body"
        .Display
        .Attachments.Add (Path & PDF)
        .Attachments.Add (Path & zip)
        .Send
    End With

Answer 1

尝试检查文件锁定状态，而不是每个项目延迟 1 秒：

Option Explicit

Sub WaitForFreeFile()
    Dim path As String, counter As Integer
    path = "c:\Users\Alex20\Documents\emptyZIP.zip"
    
    ' the process of copying a 100 MB file into a .zip has started
    
    Do While isLocked(path)
        If counter = 0 Then Debug.Print "File is locked @ " & Now   'debugging info
        counter = counter + 1                                       'debugging info
        Application.Wait Now + TimeSerial(0, 0, 1)
        Debug.Print "Check file status # " & counter & " @ " & Now  'debugging info
        DoEvents
    Loop
    Debug.Print "The file has been released @ " & Now
    
    ' your code
End Sub

Function isLocked(fullpath As String)
    Dim ff As Integer
    ff = FreeFile
    On Error Resume Next
    Open fullpath For Input Lock Read As #ff
    isLocked = Err.Number <> 0
    Close #ff
End Function

输出

File is locked @ 31.05.2021 15:02:16
Check file status # 1 @ 31.05.2021 15:02:17
Check file status # 2 @ 31.05.2021 15:02:18
Check file status # 3 @ 31.05.2021 15:02:19
Check file status # 4 @ 31.05.2021 15:02:20
Check file status # 5 @ 31.05.2021 15:02:21
The file has been released @ 31.05.2021 15:02:21

另请注意，如果某些项目不会被复制（例如空文件夹）并且第一个 .Count 永远不会等于第二个 .Count，Do Until ...items.Count = ....items.Count 可能不会完成。