excelvbapowerpoint

Deleting content on powerpoint using VBA


I have a weekly presentation that I'm trying to automate. Each week I delete all of the previous weeks contents and paste in the new data using a macro in excel. However I cannot figure out how to delete all of the previous contents. Note: I do not want to delete the slides, just the pictures that are on the slides.

Edited: Below is the code I use in excel to paste in the new data each week. This code is for a single slide. Is it possible to add code to delete the previous weeks data before pasting in the new data?

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

Solution

  • try this;

        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
    

    EDIT:If you want to delete images on only slides 14 to 2 you can do this. Ignore my comments they were wrong. But the below code will work for you.

    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