Как скопировать разделы PowerPoint в новую презентацию с помощью VBA

Обычно мы используем PowerPoint для облегчения наших экспериментов. Мы используем «разделы» в PowerPoint, чтобы объединять группы слайдов для каждой экспериментальной задачи. Перемещение разделов, чтобы уравновесить порядок задач эксперимента, потребовало огромных усилий!

Я думал, что мы могли бы заранее определить порядок уравновешивания (используя строку чисел, представляющую порядок) в CSV или массиве (еще не построили это в VBA). Затем с помощью VBA переместите разделы и сохраните файл для каждого заказа. Я довольно давно использую VBA, но думаю, что у меня неплохой старт. Проблема находится в строке 24. Я не знаю, как скопировать раздел в новую презентацию. Кто-нибудь достаточно знаком, чтобы направить меня по правильному пути.

Sub Latin_Square()
    Dim amountOfSubjects As Integer
    'Declare the amount of subjects you have in your study
    amountOfSubjects = 14

    Dim filePath As String
    filePath = "C:/1.pptx"

    Dim amountofsections As Integer
    Dim i As Integer
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim desktopPath As String
    'find out where user's desktop is
    desktopPath = Environ("UserProfile") & "\Desktop\"


    Dim oldPresentation As Presentation
    Dim newPresentation As Presentation
    'open the target presentation
    Set oldPresentation = Presentations.Open("C:\1.pptx")
    For i = 1 To oldPresentation.Slides.Count
        oldPresentation.Slides.Item(i).Copy
        newPresentation.Item(1).Slides.Paste
    Next i
    oldPresentation.Close

    With newPresentation
        .SaveCopyAs _
            FileName:=fso.BuildPath(desktopPath, "Test" & 1 & ".pptx"), _
            FileFormat:=ppSaveAsOpenXMLPresentation
    End With

End Sub

vba sections powerpoint copying
person Joel Persinger    schedule 15.06.2019    source источник

Ответы (1)


arrow_upward
2
arrow_downward

Если вы хотите скопировать слайды с их разделами, вы не можете вставить слайд только newPresentation.Slides.Paste, так как это перемещает раздел последнего слайда на только что вставленный слайд.

Вот пример того, как копировать слайд за слайдом, проверять, является ли слайд началом раздела, и как затем добавить новый раздел:

Public Sub CopySlidesWithSections()
    Dim oldPresentation As Presentation, newPresentation As Presentation
    Dim oldSlide As Slide, newSlide As Slide
    Dim oldSectionProperties As SectionProperties, newSectionProperties As SectionProperties
    Dim i As Integer

    Set oldPresentation = ActivePresentation
    Set oldSectionProperties = oldPresentation.SectionProperties

    Set newPresentation = Application.Presentations.Add
    Set newSectionProperties = newPresentation.SectionProperties

    For Each oldSlide In oldPresentation.Slides
        oldSlide.Copy
        ' Would lead to wrong sectioning: Set newSlide = newPresentation.Slides.Paste.Item(1)
        Set newSlide = newPresentation.Slides.Paste(newPresentation.Slides.Count + 1).Item(1)

        For i = 1 To oldSectionProperties.Count
            If oldSectionProperties.FirstSlide(i) = oldSlide.SlideIndex Then
                newSectionProperties.AddBeforeSlide _
                    newSlide.SlideIndex, _
                    oldSectionProperties.Name(i)
                Exit For
            End If
        Next i
    Next oldSlide
End Sub
person Asger    schedule 16.06.2019
comment
Спасибо! Это сработало! Я собираюсь добавить в код перетасовки латинского квадрата. Я могу опубликовать еще раз! - person Joel Persinger; 18.06.2019