使用源格式粘贴幻灯片时PowerPoint VBA导出PDF失败求助

我有一个宏，可将演示文稿的每张幻灯片保存为单独PDF文件，文件名取自幻灯片内指定文本框。但当使用「保留源格式」粘贴新建幻灯片时，PDF保存功能失效，抛出运行时错误-2147467259 (80004005)，提示「所选打印幻灯片已不存在，请重新选择」。原代码如下：

Sub SplitSlidesIntoSeparateFilesv4()
    Dim SourcePres As Presentation
    Dim NewPres As Presentation
    Dim SourceSlide As Slide
    Dim FilePaath As String
    Dim FileName As String

    ' Set the source presentation
    Set SourcePres = ActivePresentation

    ' Choose the folder to save the files
    FilePath = InputBox("Enter the full path where you want to save the files:", "File Path")
    If FilePath = "" Then Exit Sub ' Exit if no path is provided
    
    ' The shape in the slide that contains the text to name the converted file .
    shapeName = "Rectangle 35"

    ' Loop through each slide in the presentation
    For Each SourceSlide In SourcePres.Slides
        ' Create a new presentation
        Set NewPres = Presentations.Add
        ' Copy the slide
        SourceSlide.Copy
        ' Paste the slide into the new presentation. <<< Introduction of this causes the error >>>
        NewPres.Windows(1).Activate
        NewPres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
        
        ' Previous code, which works fine is below.  It does not do source formatting, but saving as pdf works fine.
        ' NewPres.Slides.Paste
        
        ' Save the new presentation
        
        For Each Shape In SourceSlide.Shapes
            ' Check if the shapes name matches the specified name
            If Shape.Name = shapeName Then
                FileName = FilePath & "\" & "Slide_" & Shape.TextFrame.TextRange.Text & ".pdf"
                NewPres.ExportAsFixedFormat _
                Path:=FileName, _
                FixedFormatType:=ppFixedFormatTypePDF, _
                Intent:=ppFixedFormatIntentScreen, _
                FrameSlides:=msoTrue, _
                HandoutOrder:=ppPrintHandoutVerticalFirst, _
                OutputType:=ppPrintOutputSlides, _
                PrintHiddenSlides:=msoCTrue, _
                PrintRange:=Nothing, _
                RangeType:=ppPrintAll, _
                IncludeDocProperties:=True, _
                DocStructureTags:=True, _
                BitmapMissingFonts:=True, _
                UseISO19005_1:=False
                
            End If
        Next Shape
    Next SourceSlide
End Sub

问题原因 #

CommandBars.ExecuteMso ("PasteSourceFormatting")属于UI层面的异步操作，代码不会等待粘贴完成就直接执行后续的PDF保存逻辑。此时新演示文稿中还未生成幻灯片，调用ExportAsFixedFormat自然会触发「幻灯片不存在」的错误。而原代码中NewPres.Slides.Paste是VBA同步方法，能确保幻灯片粘贴完成后再执行后续步骤，因此不会报错。

解决方案 #

添加等待逻辑，确保幻灯片粘贴完成后再执行保存操作；同时增加错误判断，避免无效操作。修改后的代码如下：

Sub SplitSlidesIntoSeparateFilesv4()
    Dim SourcePres As Presentation
    Dim NewPres As Presentation
    Dim SourceSlide As Slide
    Dim FilePath As String
    Dim FileName As String
    Dim shapeName As String
    Dim waitTime As Double
    
    ' 设置源演示文稿
    Set SourcePres = ActivePresentation

    ' 选择保存路径
    FilePath = InputBox("输入保存文件的完整路径：", "文件路径")
    If FilePath = "" Then Exit Sub ' 未提供路径则退出
    
    ' 用于提取文件名的文本框形状名称
    shapeName = "Rectangle 35"

    ' 遍历每张幻灯片
    For Each SourceSlide In SourcePres.Slides
        ' 创建新演示文稿
        Set NewPres = Presentations.Add
        ' 复制源幻灯片
        SourceSlide.Copy
        ' 激活新演示文稿窗口并执行保留源格式粘贴
        NewPres.Windows(1).Activate
        NewPres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
        
        ' 等待幻灯片粘贴完成，最多等待5秒
        waitTime = Timer + 5
        Do While NewPres.Slides.Count = 0 And Timer < waitTime
            DoEvents ' 释放CPU资源，让系统完成粘贴操作
        Loop
        
        ' 检查是否成功粘贴幻灯片
        If NewPres.Slides.Count = 0 Then
            MsgBox "幻灯片" & SourceSlide.SlideIndex & "粘贴失败，跳过保存", vbExclamation
            NewPres.Close SaveChanges:=ppDoNotSaveChanges
            Set NewPres = Nothing
            GoTo NextSlide
        End If
        
        ' 提取文件名并保存为PDF
        For Each Shape In SourceSlide.Shapes
            If Shape.Name = shapeName Then
                FileName = FilePath & "\" & "Slide_" & Shape.TextFrame.TextRange.Text & ".pdf"
                NewPres.ExportAsFixedFormat _
                    Path:=FileName, _
                    FixedFormatType:=ppFixedFormatTypePDF, _
                    Intent:=ppFixedFormatIntentScreen, _
                    FrameSlides:=msoTrue, _
                    HandoutOrder:=ppPrintHandoutVerticalFirst, _
                    OutputType:=ppPrintOutputSlides, _
                    PrintHiddenSlides:=msoCTrue, _
                    PrintRange:=Nothing, _
                    RangeType:=ppPrintAll, _
                    IncludeDocProperties:=True, _
                    DocStructureTags:=True, _
                    BitmapMissingFonts:=True, _
                    UseISO19005_1:=False
                Exit For ' 找到目标形状后退出循环，提升效率
            End If
        Next Shape
        
        ' 关闭新演示文稿，不保存
        NewPres.Close SaveChanges:=ppDoNotSaveChanges
        Set NewPres = Nothing
NextSlide:
    Next SourceSlide
End Sub

修改说明 #

• 增加等待循环，通过DoEvents释放资源，确保系统完成粘贴操作后再执行保存
• 添加粘贴失败判断，避免无效的PDF保存操作并给出提示
• 找到目标文本框后立即退出循环，提升代码执行效率
• 修正原代码中FilePaath的拼写错误

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