Выберите слайды Powerpoint на основе тегов слайдов и скопируйте в новую презентацию

Question

У меня есть колода из 30 слайдов, представляющая собой смесь слайдов для разных областей (Azure, AWS и c.). Моя цель состоит в том, чтобы иметь возможность извлекать определенные c слайды в новую презентацию на основе требований. Например, вытащите все слайды, связанные с Azure. Итак, для этого я назначил теги каждому слайду (https://docs.microsoft.com/en-us/office/vba/api/powerpoint.slide.tags). Теперь мне нужна помощь в использовании этих тегов для извлечения этих слайдов из основной колоды PowerPoint в новую колоду PowerPoint.

Код для назначения тегов:

Sub Assign_tags()
ActivePresentation.Slides(7).Tags.Add "pname", "Azure"
ActivePresentation.Slides(8).Tags.Add "pname", "Azure"
ActivePresentation.Slides(9).Tags.Add "pname", "Azure"
ActivePresentation.Slides(10).Tags.Add "pname", "Azure"
ActivePresentation.Slides(11).Tags.Add "pname", "Azure"
ActivePresentation.Slides(12).Tags.Add "pname", "Azure"
ActivePresentation.Slides(13).Tags.Add "pname", "Azure"
ActivePresentation.Slides(14).Tags.Add "pname", "Azure"
ActivePresentation.Slides(15).Tags.Add "pname", "Azure"
ActivePresentation.Slides(16).Tags.Add "pname", "Azure"
ActivePresentation.Slides(17).Tags.Add "pname", "Azure"
ActivePresentation.Slides(18).Tags.Add "pname", "Azure"
ActivePresentation.Slides(19).Tags.Add "pname", "Azure"
ActivePresentation.Slides(20).Tags.Add "pname", "Azure"
ActivePresentation.Slides(21).Tags.Add "pname", "Azure"
ActivePresentation.Slides(22).Tags.Add "pname", "Azure"
ActivePresentation.Slides(23).Tags.Add "pname", "Azure"
ActivePresentation.Slides(24).Tags.Add "pname", "Azure"
ActivePresentation.Slides(25).Tags.Add "pname", "Azure"
ActivePresentation.Slides(26).Tags.Add "pname", "Azure"

ActivePresentation.Slides(27).Tags.Add "pname", "AWS"

ActivePresentation.Slides(28).Tags.Add "pname", "GCP"
End Sub

Код для копирования слайдов с тегом Azure в новую презентацию

    Sub SaveSeparateSlide2()

    Dim curPres As Presentation
    Set curPres = ActivePresentation
    Dim newPres As Presentation
    Set newPres = Presentations.Add

For Each s In curPres.Slides

    If s.Tags("pname") = "Azure" Then

      s.Copy
      newPres.Slides.Paste

    End If

Next

    'change your path and name here:
    newPres.SaveAs "Azure slides.pptx"
    newPres.Close

End Sub

Answer 1

Option Explicit


Sub Assign_tags()
ActivePresentation.Slides(1).Tags.Add "pname", "Azure"
ActivePresentation.Slides(2).Tags.Add "pname", "AWS"
ActivePresentation.Slides(3).Tags.Add "pname", "Azure"
ActivePresentation.Slides(4).Tags.Add "pname", "GCP"
End Sub

Sub extract_slides()

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
         ' Paste it in new Presentation
        newPresentation.Slides.Paste
    End If
Next

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

End Sub

Answer 2

Я бы посоветовал использовать For Loop для назначения тегов вместо нескольких одинаковых строк кода:

For i = 7 To 26
ActivePresentation.Slides(i).Tags.Add "pname", "Azure"
Next i

Теперь нам нужно выбрать слайды, содержащие тег pname со значением azure

    Dim slNum() As Integer
    Dim n As Integer
'above are global declarations

    n = -1 'do this in some initialise sub-routine

Sub SelectSlides()
    For Each s In Application.ActivePresentation.Slides
    With s.Tags
        For i = 1 To .Count
          If .Value(i) = "Azure" Then
          n = n + 1
          ReDim Preserve slNum(n)
          slNum(n) = .Parent.SlideIndex 'We now stored the slide number of the slide which contains the tag 
          End If
        Next i
    End With
    Next
End Sub

Вместо дублирования слайда вы также можете скопировать и вставить этот слайд в нужный индекс.

Sub copy()
    ActivePresentation.Slides(i).Copy
    ActivePresentation.Slides.Paste Index:=5
End Sub

Если вы хотите переместить слайд:

Sub move()
    ActivePresentation.Slides(3).MoveTo ToPos:=1
End Sub

Надеюсь, это поможет вам!

РЕДАКТИРОВАТЬ: Чтобы перенести выбранные слайды в новую презентацию:

Dim pptApp As Object
Dim pptPS As Object

Set pptApp = CreateObject("Powerpoint.Application")
Set pptPS = pptApp.Presentations.Add

pptPS.SaveAs "Type folder path here"

For i = 0 To n
ActivePresentation.Slides.Item(i).Copy
pptPS.Item(1).Slides.Paste
Next i

pptPS.Save
pptPS.Close
pptApp.Quit

Set pptPS = Nothing
Set pptApp = Nothing

Я не проверял выше код, я не думаю, что он будет работать, как есть (чувство кишки). Пожалуйста, удалите ошибку.