VBA Command to delete all shapes in specific PPT slides

Hi all,

I got a perfectly working VBA macro, but it deletes all shapes on ALL slides in the active PowerPoint.

Code:

---

Sub DeleteAllGraphsInPPT()
'This macro will only work if there is an active PowerPoint
'It removes all shapes, pictures and tables in the active PowerPoint
    Dim objApp, objSlide, ObjShp, objTable
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0
    'If the presentation is open, check each slides for shapes, pictures and/or tables
    'and deletes them if they exist
    For Each objSlide In objApp.ActivePresentation.Slides
    For Each ObjShp In objSlide.Shapes
    If ObjShp.Type = msoPicture Then
    ObjShp.Delete
    ElseIf ObjShp.Type = msoTable Then
    ObjShp.Delete
    ElseIf ObjShp.Type = msoChart Then
    ObjShp.Delete
    End If
    Next
    Next
End Sub

---

Is it possible to modify it and only delete all shapes from slides 2 until 8?

Yours sincerely,

Djani

Yes it is possible, and yes you can modify this code yourself (eitje !) if you try to analyse what each line does.

Which slide number?

Quote:

---

http://skp.mvps.org/ppt00030.htm

---

Quote:

---

The SlideIndex property returns the actual position of the slide within the presentation. The SlideNumber property returns the PageNumber which will appear on that slide. This property value is dependent on "Number Slide from" option in the Page Setup.

---

Slide numbers 2, 3, 4, 5, 6, 7, 8 in the active PowerPoint, but give me some time to figure it out myself!

I might be thinking too hard right now as I still can't figure it out - macro not working. However, I had the following in mind:

Code:

---

Sub DeleteAllGraphsInPPT()
'This macro will only work if there is an active PowerPoint
'It removes all shapes, pictures and tables in the active PowerPoint
    Dim objApp, objSlide, ObjShp, objTable
    For i = 2 To 8
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0
    'If the presentation is open, check each slides for shapes, pictures and/or tables
    'and deletes them if they exist
    For Each ActivePresentation.Slides(i) In ActivePresentation
    For Each ObjShp In objSlide.Shapes
    If ObjShp.Type = msoPicture Then
    ObjShp.Delete
    ElseIf ObjShp.Type = msoTable Then
    ObjShp.Delete
    ElseIf ObjShp.Type = msoChart Then
    ObjShp.Delete
    End If
    Next
End Sub

---

Is the logic good?

@Paul_Hossler: I took a look at the site, but I am not sure how to integrate the variable SlideNumber/SlideIndex in the current macro.

Quote:

---

I took a look at the site, but I am not sure how to integrate the variable SlideNumber/SlideIndex in the current macro.

---

Just a cautionary note about the slide number displayed and the slide number in the presentation

Most likely you're OK

Not tested, but I reversed your inner and out loops

Code:

---

Option Explicit
Sub DeleteAllGraphsInPPT()
    'This macro will only work if there is an active PowerPoint
    'It removes all shapes, pictures and tables in the active PowerPoint
    Dim objApp As Object, objSlide As Object, ObjShp As Object, objTable As Object
    Dim i As Long
   
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0
   
    If objApp Is Nothing Then Exit Sub
   
    If objApp.activepresentation Is Nothing Then Exit Sub
   
    For i = 2 To 8
        Set objSlide = objApp.activepresentation.slides(i)
        For Each ObjShp In objSlide.Shapes
            Select Case ObjShp.Type
                Case msoPicture, msoTable, msoChart
                    ObjShp.Delete
            End Select
        Next
    Next i
End Sub

---

:bow: Worked instantly! Thanks.... You are a life saver!

Quote:

---

Originally Posted by Paul_Hossler

Just a cautionary note about the slide number displayed and the slide number in the presentation

Most likely you're OK

Not tested, but I reversed your inner and out loops

Code:

---

Option Explicit
Sub DeleteAllGraphsInPPT()
    'This macro will only work if there is an active PowerPoint
    'It removes all shapes, pictures and tables in the active PowerPoint
    Dim objApp As Object, objSlide As Object, ObjShp As Object, objTable As Object
    Dim i As Long
   
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0
   
    If objApp Is Nothing Then Exit Sub
   
    If objApp.activepresentation Is Nothing Then Exit Sub
   
    For i = 2 To 8
        Set objSlide = objApp.activepresentation.slides(i)
        For Each ObjShp In objSlide.Shapes
            Select Case ObjShp.Type
                Case msoPicture, msoTable, msoChart
                    ObjShp.Delete
            End Select
        Next
    Next i
End Sub

---

---

Glad it still worked for you, but be advised this was a 2-3 year old thread so if there's other questions, make sure to start a new one

Even thought this is 'sort of' a PP question posted in Excel, I moved it to the PP forum

And a few comments
CreateObject will create a NEW empty presentation if none is open.

You might want to try

Code:

---

Set objApp = GetObject(Class:="Powerpoint.Application")

---

If objApp.activepresentation Is Nothing Then Exit Sub Is not a valid test. It will throw an error if no ActivePresentation is there.

Always loop backwards when deleting shapes. As written the code will usually work but not always.

Most important the test for charts,pictures and tables will fail if they are in placeholders. You need to check the contained type of placeholders.