none
[Powerpoint] Shapes collection limiation? RRS feed

  • Question

  • Hello everyone,

    So I'm running the following code in my presentation:

    Dim SldSearch As Slide
    Dim ShpSearch As Shape
    
    For Each SldSearch In ActivePresentation.Slides
        If SldSearch.Shapes.Count > 50 Then
                     
            For Each ShpSearch In SldSearch.Shapes
                ShpSearch.Delete
            Next
        End If
    Next

    I'm running it on slides with a very large number of shapes (>5000) and the interesting thing is that it is not deleting all the shapes, but only some of them. If I run it a second time, it deletes some more and so on, and so on.

    I don't understand what is going wrong here. Does anyone knows?

    The purpose of the final code is to filter the shapes to delete and not to delete, so something like:

    SldSearch.Shapes.Range.Delete

    Will not do the trick.

    Thanks for your help.

    Monday, August 24, 2015 6:35 PM

Answers

  • I think its how the For Each loop works. Deleting some of the shapes causes problems. However the following deleted all shapes for me.

    Sub Test()
    Dim SldSearch As Slide
    Dim shpId As Long
        For Each SldSearch In ActivePresentation.Slides
            If SldSearch.Shapes.Count > 50 Then
                For shpId = SldSearch.Shapes.Count To 1 Step -1
                    SldSearch.Shapes(shpId).Delete
                Next
            End If
        Next
    End Sub


    Rod Gill
    Author of the one and only Project VBA Book
    www.project-systems.co.nz

    • Marked as answer by marvalar Tuesday, August 25, 2015 7:24 AM
    Monday, August 24, 2015 11:20 PM

All replies

  • I think its how the For Each loop works. Deleting some of the shapes causes problems. However the following deleted all shapes for me.

    Sub Test()
    Dim SldSearch As Slide
    Dim shpId As Long
        For Each SldSearch In ActivePresentation.Slides
            If SldSearch.Shapes.Count > 50 Then
                For shpId = SldSearch.Shapes.Count To 1 Step -1
                    SldSearch.Shapes(shpId).Delete
                Next
            End If
        Next
    End Sub


    Rod Gill
    Author of the one and only Project VBA Book
    www.project-systems.co.nz

    • Marked as answer by marvalar Tuesday, August 25, 2015 7:24 AM
    Monday, August 24, 2015 11:20 PM
  • Thanks, that works!

    I found a slightly more efficient way of doing what I wanted.

    Basically, by parsing all the objects in the slide and building an array with the object names that I wanted to preserve. Then, I copy those objects to the clipboard, delete everything and then paste the copied objects back.

    Dim SldSearch As Slide
    Dim ShpSearch As Shape
    
    
    Dim i As Long
    
    Dim OpInstShape() As String
    
    Dim NrOpInstShape As Integer
    
    For Each SldSearch In ActivePresentation.Slides
        NrOpInstShape = 0
        If SldSearch.Shapes.Count > 50 Then
            
            For Each ShpSearch In SldSearch.Shapes
    
                If ShpSearch.Type = msoTextBox Then
                    If ShpSearch.TextFrame.TextRange.Runs(1).Font.Color.RGB = RGB(255, 0, 0) Then
                        With ShpSearch
                            .Fill.ForeColor.RGB = RGB(0, 180, 255)
                            With .TextFrame.TextRange.Font
                                .Size = 7
                                .Name = "Arial"
                            End With
                            With .TextFrame.TextRange.ParagraphFormat
                                .LineRuleWithin = msoTrue
                                .SpaceWithin = 1
                            End With
                        End With
                        NrOpInstShape = NrOpInstShape + 1
                        ReDim Preserve OpInstShape(1 To NrOpInstShape)
                        OpInstShape(NrOpInstShape) = ShpSearch.Name
                    
                    End If
                End If
            Next
                If NrOpInstShape > 0 Then
                    SldSearch.Shapes.Range(OpInstShape).Copy
                    SldSearch.Shapes.Range.Delete
                    SldSearch.Shapes.Paste
                End If
        End If
    Next


    Tuesday, August 25, 2015 7:41 AM