Удаление контента в PowerPoint с использованием VBA

Question

У меня есть еженедельная презентация, которую я пытаюсь автоматизировать. Каждую неделю я удаляю все содержимое предыдущих недель и вставляю новые данные с помощью макроса в Excel. Однако я не могу понять, как удалить все предыдущее содержимое. Примечание. Я не хочу удалять слайды, только изображения, которые находятся на слайдах.

Отредактировано: ниже приведен код, который я использую в Excel для вставки новых данных каждую неделю. Этот код для одного слайда. Можно ли добавить код для удаления данных предыдущих недель перед вставкой в ​​новые данные?

Sub PasteAltSummaryToDeck()
'PURPOSE: Copy alt summary page and paste into weekly deck'

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'Create an Instance of PowerPoint
  On Error Resume Next

'Is PowerPoint already opened?
  Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
  Err.Clear

'If PowerPoint is not already open then Exit
  If PowerPointApp Is Nothing Then
    MsgBox "PowerPoint Presentation is not open, aborting."
    Exit Sub
  End If

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

  On Error GoTo 0

'Make PowerPoint Visible and Active
  PowerPointApp.ActiveWindow.Panes(2).Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation

'List of PPT Slides to Paste to
  MySlideArray = Array(11)

'List of Excel Ranges to Copy from
    MyRangeArray = Array(Sheet2.Range("F5:AS60"))

'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
        MyRangeArray(x).Copy

'Paste to PowerPoint and position
  On Error Resume Next
    Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
  On Error GoTo 0

'Center Object
  With myPresentation.PageSetup
    shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
    shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
  End With

  Next x

   'Record the date & time of procedure execution
    Range("ExportAltSumToPPT").Value = Format(Now(), "mm/dd/yy") & " - " & 
Format(TimeValue(Now), "hh:mm AM/PM")

'Transfer Complete
  Application.CutCopyMode = False
 ThisWorkbook.Activate
  MsgBox "Complete!"


End Sub

Answer 1

Для удаления содержимого слайдов с помощью Excel вы можете использовать следующий код:

Option Explicit

Sub remove_previous_shapes_in_PPT()
    Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
    Dim i As Long, j As Long
    Set ppt = GetObject(, "PowerPoint.Application")
    Set pr = ppt.Presentations(1)
    sl_cnt = pr.Slides.Count
    For j = sl_cnt To 2 Step -1
        Set sl = pr.Slides(j)
        For i = sl.Shapes.Count To 1 Step -1
            sl.Shapes(i).Delete
        Next i
    Next j
End Sub

При этом используется циклический просмотр количества слайдов и вложенный цикл прохождения фигур внутри слайда. В приведенном выше коде я оставляю слайд 1 один (вы можете просто изменить цикл для j, чтобы перейти к 1, а не 2, если вы хотите удалить содержимое первого слайда).

Обратите внимание на элементы, помеченные as Object против тех, которые связаны с ссылками PPT. Я не прошел через шаги по использованию вашего конкретного PPT, поскольку я обычно имею дело с GetObject() для активного окна PPT, когда открыта только 1 презентация.

Answer 2

попробуйте это;

    Sub deletepics()

        'variables
        Dim slide As slide
        Dim y As Long

        'loop through slides backwards and with the slides shapes if they are pictures then delete
        For Each slide In ActivePresentation.Slides 
            For y = slide.Shapes.Count To 1 Step -1
                With slide.Shapes(y)
                    If .Type = msoPicture Then
                        .Delete
                    End If
                End With
            Next
        Next

    End Sub

РЕДАКТИРОВАТЬ: Если вы хотите удалить изображения только на слайдах с 14 по 2, вы можете сделать это. Игнорируйте мои комментарии, они были неправы. Но приведенный ниже код будет работать для вас.

Sub deletepics()

    'variables
    Dim slide As slide
    Dim y As Long
    'loop through slides backwards and with the slides shapes if they are pictures then delete


For y = ActivePresentation.Slides.Count To 2 Step -1
    If y <> 14 Then
        Set sldTemp = ActivePresentation.Slides(y)
            For lngCount = sldTemp.Shapes.Count To 1 Step -1
                    With sldTemp.Shapes(lngCount)
                        If .Type = msoPicture Then
                            .Delete
                        End If
                    End With
            Next
    End If
Next

End Sub