Excel VBA生成PDF作为Outlook附件在Win11下损坏问题求助

• 运行环境：Excel VBA 2507（Build 19029.20208），Windows 10旧笔记本上程序正常，Windows 11 x64新笔记本（安装2025-08累积更新KB5063878，版本26100.4946）出现异常
• 异常现象：生成的PDF文件本身完好，但添加到Outlook邮件的附件损坏；手动添加大循环延迟后程序可正常运行
• 初步推测：新设备性能过高，导致PDF未完全写入磁盘时，就被Outlook读取作为附件，引发损坏

核心问题是文件写入的异步性：

• 使用PrintOut生成PDF时，Excel会启动后台进程完成文件写入，但VBA代码不会等待后台操作结束，会直接执行后续逻辑
• 旧设备性能差，PDF写入完成前，邮件代码还没走到添加附件的步骤；新设备性能高，写入未完成就执行了.Attachments.Add，此时文件处于未完全写入状态，导致附件损坏
• 大循环延迟本质是靠硬等待让PDF写入完成，但这种方式不可靠——不同设备需要的延迟时间不同，还会浪费系统资源

方案1：用同步方法生成PDF（推荐） #

替换PrintOut为ExportAsFixedFormat，这个方法是同步执行的，会等待PDF完全生成后才继续执行后续代码，无需额外等待逻辑：

' 替换原来的PrintOut代码
ActiveWindow.SelectedSheets.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=lcPDFname, _
    IgnorePrintAreas:=False

方案2：等待文件写入完成 #

通过检测文件是否可被独占打开，确认PDF已完全写入磁盘，避免硬延迟：

Sub WaitForFileReady(filePath As String)
    Dim fileNum As Integer
    Dim errNum As Integer
    Do
        On Error Resume Next
        fileNum = FreeFile()
        Open filePath For Input Lock Read Write As #fileNum
        Close fileNum
        errNum = Err.Number
        On Error GoTo 0
        ' 每次等待100毫秒后重试
        If errNum <> 0 Then Application.Wait Now + TimeValue("00:00:00.1")
    Loop Until errNum = 0
End Sub

在生成PDF后调用这个函数：

'Create and save PDF
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
printtofile:=True, prtofilename:=lcPDFname, IgnorePrintAreas:=False
' 等待PDF写入完成
Call WaitForFileReady(lcPDFname)

方案3：用Windows API检测文件占用 #

通过API判断文件是否被其他进程占用，实现更精确的等待：

Private Declare PtrSafe Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As LongPtr, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long

Const INVALID_HANDLE_VALUE = -1
Const FILE_SHARE_NONE = &H0
Const OPEN_EXISTING = 3

Sub WaitForFileRelease(filePath As String)
    Dim hFile As LongPtr
    Do
        hFile = CreateFile(filePath, 0, FILE_SHARE_NONE, 0, OPEN_EXISTING, 0, 0)
        If hFile <> INVALID_HANDLE_VALUE Then
            CloseHandle hFile
            Exit Do
        End If
        Application.Wait Now + TimeValue("00:00:00.1")
    Loop
End Sub

调用方式和方案2一致。

Sub part()
    'Create and save PDF (用同步方法替代PrintOut)
    ActiveWindow.SelectedSheets.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=lcPDFname, _
        IgnorePrintAreas:=False
        
    'Generate strings to be pasted into the email
    lcFundMsg = WorksheetFunction.Round((Range("Fund").Value), 2)
    lcUnitCash = WorksheetFunction.Round(Range("UnitValue").Value, 2)
    
    'and tidy both to £0.00 format
    Call CashFix(lcFundMsg)
    Call CashFix(lcUnitCash)
    
    lcFundMsg = "No Club handicap reductions." & vbNewLine & "Paid to the fund this session £" & lcFundMsg & " @ " & _
    lcUnitCash & "p/game." '& vbNewLine & "Michael."
    
    '无需延迟，直接生成邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    lcSignBy = "Michael"
    
    With OutMail
        .To = "Starters"
        .CC = ""
        .BCC = ""
        .Subject = "Diddly Results Sheet for " & lvDate 'RsltHdr.Value
        .Body = lcFundMsg & vbNewLine & lcSignBy
        .Attachments.Add lcPDFname
        .Display
    End With 'OutMail
    
    '释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub 

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