PowerPoint VBA 在目标 PowerPoint 中保留源格式答案

【问题标题】：PowerPoint VBA to retain source formatting in destination PowerPointPowerPoint VBA 在目标 PowerPoint 中保留源格式
【发布时间】：2020-04-25 14:50:26
【问题描述】：

我有以下代码可以将特定幻灯片（基于标签）复制到新的演示文稿中。我想在目标演示文稿的复制幻灯片中保留源演示文稿的格式。

当前代码：

Option Explicit
Private Sub CommandButton1_Click()

Dim strTagName As String
Dim strTagValue As String

strTagName = "pname"
strTagValue = "Azure"

Dim currentPresentation As Presentation
Dim newPresentation As Presentation
Dim s As Slide

' Save reference to current presentation
Set currentPresentation = Application.ActivePresentation

' Save reference to current slide
'Set currentSlide = Application.ActiveWindow.View.Slide

' Add new Presentation and save to a reference
Set newPresentation = Application.Presentations.Add

For Each s In currentPresentation.Slides
    If s.Tags(strTagName) = "Azure" Then

    s.Copy
    newPresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

    End If

Next

newPresentation.SaveAs (currentPresentation.Path & "\" & strTagValue & "_Quals Slides.pptx")

End Sub

【问题讨论】：

请看这个帖子：stackoverflow.com/questions/16338295/…
John Korchok - 非常感谢！我能够使用暂停脚本修复它！上帝保佑。我在下面添加了工作代码。

标签： vba powerpoint

【解决方案1】：

Option Explicit
Private Sub CommandButton1_Click()

Dim strTagName As String
Dim strTagValue As String

strTagName = "pname"
strTagValue = "Azure"

Dim currentPresentation As Presentation
Dim newPresentation As Presentation
Dim s As Slide

' Save reference to current presentation
Set currentPresentation = Application.ActivePresentation

' Save reference to current slide
' Set currentSlide = Application.ActiveWindow.View.Slide

' Add new Presentation and save to a reference
Set newPresentation = Application.Presentations.Add

For Each s In currentPresentation.Slides
    If s.Tags(strTagName) = "Azure" Then

    s.Copy
    newPresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
    For i = 1 To 5000: DoEvents: Next

    End If

Next

newPresentation.SaveAs (currentPresentation.Path & "\" & strTagValue & "_Quals Slides.pptx")

End Sub

【讨论】：