VBA中Worksheet类PrintOut方法调用失败（运行时错误4001）求助

我用VBA代码将Excel文件打印为PDF，但只有30%的成功率，多次执行后会抛出**“Worksheet类的PrintOut方法失败。运行时错误4001”**。已经尝试添加等待时间、更换ActivePrinter参数（比如Ne01、Ne02等），但只有关闭所有Excel或重启电脑后能成功1-2次，之后还是报错。

原代码如下：

flNmPrt = invPdf & custNm & "_" & invNo & "_" & sDate & "_" & curHr & curMin & curSec & ".pdf"
Application.Wait (Now + TimeValue("00:00:02")) 'wait 2 seconds
  
ActiveSheet.PrintOut ActivePrinter:="Microsoft Print to PDF on Ne02:", PrintToFile:=True, PrToFileName:=flNmPrt

'    ActiveSheet.PrintOut ActivePrinter:="Microsoft Print to PDF on Ne01:", PrintToFile:=True, PrToFileName:=flNmPrt
'    ActiveSheet.PrintOut ActivePrinter:="Microsoft Print to PDF", PrintToFile:=True, PrToFileName:=flNmPrt
  
Application.Wait (Now + TimeValue("00:00:02")) 'wait 2 seconds

解决方案 #

1. 改用Excel原生PDF导出方法（最推荐） #

PrintOut依赖打印机驱动，容易出现资源占用和端口匹配问题，而ExportAsFixedFormat是Excel原生的PDF导出接口，稳定性更高，无需依赖打印机：

flNmPrt = invPdf & custNm & "_" & invNo & "_" & sDate & "_" & curHr & curMin & curSec & ".pdf"

' 直接导出为PDF，跳过打印机环节
ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=flNmPrt, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False

这个方法不需要等待时间，也不会受打印机端口变化影响，成功率远高于PrintOut。

2. 动态获取打印机完整名称 #

Windows会动态分配打印机端口（Ne0x），固定端口号容易失效，可通过遍历打印机列表获取正确的名称：

Dim pdfPrinter As String
' 遍历所有打印机，匹配Microsoft Print to PDF的完整名称
For Each prt In Application.Printers
    If InStr(prt.DeviceName, "Microsoft Print to PDF") > 0 Then
        pdfPrinter = prt.Name
        Exit For
    End If
Next prt

' 确认找到打印机后再执行打印
If pdfPrinter <> "" Then
    flNmPrt = invPdf & custNm & "_" & invNo & "_" & sDate & "_" & curHr & curMin & curSec & ".pdf"
    ActiveSheet.PrintOut ActivePrinter:=pdfPrinter, PrintToFile:=True, PrToFileName:=flNmPrt
Else
    MsgBox "未找到Microsoft Print to PDF打印机"
End If

3. 释放打印机资源（针对必须用PrintOut的场景） #

如果坚持使用PrintOut，每次执行后切换打印机释放资源，避免资源占用导致报错：

flNmPrt = invPdf & custNm & "_" & invNo & "_" & sDate & "_" & curHr & curMin & curSec & ".pdf"
Application.Wait (Now + TimeValue("00:00:02"))

' 先获取原打印机名称
Dim originalPrinter As String
originalPrinter = Application.ActivePrinter

' 执行打印
ActiveSheet.PrintOut ActivePrinter:="Microsoft Print to PDF on Ne02:", PrintToFile:=True, PrToFileName:=flNmPrt

' 切换到其他打印机再切回，释放资源
For Each prt In Application.Printers
    If prt.Name <> originalPrinter Then
        Application.ActivePrinter = prt.Name
        Exit For
    End If
Next prt
Application.ActivePrinter = originalPrinter

Application.Wait (Now + TimeValue("00:00:02"))

4. 检查文件路径权限 #

确保flNmPrt对应的保存路径存在且有写入权限，可提前创建目录：

' 提取保存目录路径
Dim savePath As String
savePath = Left(flNmPrt, InStrRev(flNmPrt, "\"))
' 如果目录不存在则创建
If Dir(savePath, vbDirectory) = "" Then
    MkDir savePath
End If

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