触发PDF导出时提示"Word无法完成保存，文件权限错误"的技术问询

问题背景 #

我有一个存放在远程目录的.docm文档，VBA代码结构如下：

Project(Document1)
  |_Microsoft Word Object
    |_ThisDocument

代码用于在用户保存文件时自动导出PDF：

Private WithEvents App As Word.Application

Private Sub Document_Open()
    Set App = Word.Application
End Sub

Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
    If Word.Documents.Count And ActiveDocument = ThisDocument Then
        Dim strFilename As String
        strFilename = ActiveDocument.Name
        Dim positionPoint As Integer
        positionPoint = InStr(strFilename, ".")
        If positionPoint <> 0 Then
            strFilename = Left(strFilename, positionPoint - 1)
            strPath = ActiveDocument.Path & Application.PathSeparator

            ActiveDocument.ExportAsFixedFormat outputFileName:= _
                                            strPath & strFilename & ".pdf", _
                                            ExportFormat:=wdExportFormatPDF, _
                                            OpenAfterExport:=False, _
                                            OptimizeFor:=wdExportOptimizeForOnScreen, _
                                            Range:=wdExportAllDocument, _
                                            IncludeDocProps:=False, _
                                            CreateBookmarks:=wdExportCreateNoBookmarks, _
                                            BitmapMissingFonts:=True
        End If
    End If
End Sub

运行中遇到两个问题：

1. 偶尔弹出Word Cannot Complete the Save Due to a File Permission Error提示，重试无效
2. PDF导出时长不稳定，300-500KB的文件有时要数小时，有时不到1分钟

需要解决：

• 如何修改代码确保保存安全？
• 除了BeforeSave和BeforeClose，还有哪些事件适合触发PDF导出？（BeforeClose会弹出保存提示，场景不适用）

代码优化方案 #

1. 本地导出再同步到远程（解决权限与速度问题） #

远程目录的文件锁、网络波动是核心原因，先导出到本地临时目录，再复制到远程：

' 先在ThisDocument顶部添加Sleep声明（64位Office用PtrSafe）
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private WithEvents App As Word.Application

Private Sub Document_Open()
    Set App = Word.Application
End Sub

Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
    ' 直接判断当前保存的文档是否为目标文档，比ActiveDocument更可靠
    If Not Doc Is ThisDocument Then Exit Sub
    
    Dim strBaseName As String
    ' 用InStrRev找最后一个点，避免文件名含多个点的情况（比如"report.v2.docm"）
    strBaseName = Left(Doc.Name, InStrRev(Doc.Name, ".") - 1)
    
    ' 本地临时路径（用户文档目录，权限无问题）
    Dim localPdfPath As String
    localPdfPath = Environ("USERPROFILE") & "\Documents\" & strBaseName & ".pdf"
    
    ' 导出到本地
    Doc.ExportAsFixedFormat outputFileName:=localPdfPath, _
                            ExportFormat:=wdExportFormatPDF, _
                            OpenAfterExport:=False, _
                            OptimizeFor:=wdExportOptimizeForOnScreen, _
                            Range:=wdExportAllDocument, _
                            IncludeDocProps:=False, _
                            CreateBookmarks:=wdExportCreateNoBookmarks, _
                            BitmapMissingFonts:=True
    
    ' 复制到远程目录，带重试和错误提示
    Dim remotePdfPath As String, retryCount As Integer, success As Boolean
    remotePdfPath = Doc.Path & Application.PathSeparator & strBaseName & ".pdf"
    success = False
    retryCount = 0
    
    Do While Not success And retryCount < 3
        On Error Resume Next
        Kill remotePdfPath ' 先删除旧PDF，避免文件锁定
        FileCopy localPdfPath, remotePdfPath
        If Err.Number = 0 Then
            success = True
        Else
            retryCount = retryCount + 1
            Sleep 1500 ' 等待1.5秒再重试
        End If
        On Error GoTo 0
    Loop
    
    ' 清理本地临时文件
    Kill localPdfPath
    
    If Not success Then
        MsgBox "PDF同步到远程目录失败：" & Err.Description, vbExclamation
    End If
End Sub

2. 严格的错误捕获与重试逻辑 #

针对权限错误，增加重试机制，避免单次网络波动导致失败：

Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
    If Not Doc Is ThisDocument Then Exit Sub
    
    Dim strBaseName As String, remotePdfPath As String
    strBaseName = Left(Doc.Name, InStrRev(Doc.Name, ".") - 1)
    remotePdfPath = Doc.Path & Application.PathSeparator & strBaseName & ".pdf"
    
    Dim retryCount As Integer, success As Boolean
    success = False
    retryCount = 0
    
    Do While Not success And retryCount < 3
        On Error Resume Next
        ' 导出前尝试释放文件锁
        Doc.Save ' 确保文档先保存完成
        Doc.ExportAsFixedFormat outputFileName:=remotePdfPath, _
                                ExportFormat:=wdExportFormatPDF, _
                                OpenAfterExport:=False, _
                                OptimizeFor:=wdExportOptimizeForOnScreen, _
                                Range:=wdExportAllDocument, _
                                IncludeDocProps:=False, _
                                CreateBookmarks:=wdExportCreateNoBookmarks, _
                                BitmapMissingFonts:=True
        If Err.Number = 0 Then
            success = True
        Else
            retryCount = retryCount + 1
            Sleep 1000
        End If
        On Error GoTo 0
    Loop
    
    If Not success Then
        MsgBox "PDF导出失败：" & Err.Description, vbCritical
    End If
End Sub

3. 优化文档对象判断 #

原代码用ActiveDocument = ThisDocument有风险（用户可能切换到其他文档），直接用Doc Is ThisDocument更准确，因为BeforeSave事件的Doc参数就是当前要保存的文档。

替代触发事件方案 #

1. Document_Saved事件（推荐） #

在文档成功保存后触发，不会干扰保存操作，减少权限冲突：

Private Sub Document_Saved()
    ExportToPdf ThisDocument
End Sub

Private Sub ExportToPdf(doc As Document)
    Dim strBaseName As String, remotePdfPath As String
    strBaseName = Left(doc.Name, InStrRev(doc.Name, ".") - 1)
    remotePdfPath = doc.Path & Application.PathSeparator & strBaseName & ".pdf"
    
    ' 核心导出逻辑（可复用上面的本地导出再同步代码）
    doc.ExportAsFixedFormat outputFileName:=remotePdfPath, _
                            ExportFormat:=wdExportFormatPDF, _
                            OpenAfterExport:=False, _
                            OptimizeFor:=wdExportOptimizeForOnScreen, _
                            Range:=wdExportAllDocument, _
                            IncludeDocProps:=False, _
                            CreateBookmarks:=wdExportCreateNoBookmarks, _
                            BitmapMissingFonts:=True
End Sub

2. 定时自动导出（适合频繁修改场景） #

结合Document_Change和定时检查，当文档有修改且间隔一定时间后自动导出：

Private isModified As Boolean
Private lastExportTime As Date

Private Sub Document_Open()
    isModified = False
    lastExportTime = Now
End Sub

Private Sub Document_Change()
    isModified = True
End Sub

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
    ' 每隔5分钟检查一次，如果有修改则导出
    If Now - lastExportTime > TimeValue("00:05:00") And isModified Then
        ExportToPdf ThisDocument
        isModified = False
        lastExportTime = Now
    End If
End Sub

Private Sub ExportToPdf(doc As Document)
    ' 核心导出逻辑
End Sub

3. 自定义按钮手动触发 #

添加工具栏按钮，让用户按需导出，适合不需要自动导出的场景：

Private Sub Document_Open()
    Dim cmdBtn As CommandBarButton
    ' 在标准工具栏添加按钮
    Set cmdBtn = Application.CommandBars("Standard").Controls.Add(msoControlButton, Temporary:=True)
    cmdBtn.Caption = "导出PDF到远程"
    cmdBtn.FaceId = 4 ' 设置图标（可选）
    cmdBtn.OnAction = "ExportToPdf"
End Sub

Public Sub ExportToPdf()
    ' 核心导出逻辑
End Sub

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