PowerPoint Shape not in the Shape Collection

Question

MS Access VBA Code updating a PowerPoint Presentation.

I have been frustrated with writing to PowerPoint just recently that I have had to revert to hardcoding which I hate doing but had no choice.

Using Do Until intShapes > objPPPresentation.Slides(1).Shapes.Count does not always get all Shapes on Slide 1!

This Select case code does not always find the Shape I need to update.

        Select Case objPPPresentation.Slides(intSlide).Shapes(intShapes).Name
        Case Is = "BuildingAddress"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).TextFrame.TextRange.Text = Nz(Me.txtStreetNumber, "") & " " & UCase(Nz(Me.txtAddress, ""))

So instead I did this, which works every time.

objPPPresentation.Slides(intSlide).Shapes("BuildingName").TextFrame.TextRange.Text = Nz(Me.txtStreetNumber, "") & " " & UCase(Nz(Me.txtAddress, ""))

Can anyone explain why the Shapes.Count does not always find the Shape I need to update?

This is my entire loop which includes deleting an Item and replacing it with a Picture and centering the Picture Shape! OH, Is the deletion of an item enough to throw off the code? Maybe I should delete that Shape AFTER I'm doing with the Loop?

    ' Page ONE First.
Do Until intShapes > objPPPresentation.Slides(1).Shapes.Count
    'Debug.Print objPPPresentation.Slides(intSlide).Shapes(intShapes).ID & ":" & objPPPresentation.Slides(1).Shapes(intShapes).Name

    Select Case objPPPresentation.Slides(intSlide).Shapes(intShapes).Name
        Case Is = "BuildingAddress"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).TextFrame.TextRange.Text = Nz(Me.txtStreetNumber, "") & " " & UCase(Nz(Me.txtAddress, ""))

        Case Is = "BuildingName"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).TextFrame.TextRange.Text = UCase(Nz(Me.cboBuilding.Column(1), ""))

        Case Is = "tableData"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(1).Cells(2).Shape.TextFrame.TextRange.Text = "Floors: " & Nz(Me.txtFloors, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(2).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtAvailability, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(3).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtLeaseTerm, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(4).Cells(2).Shape.TextFrame.TextRange.Text = "WHERE FROM?"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(5).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtAskingNetRent, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(6).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.TIA, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(7).Cells(2).Shape.TextFrame.TextRange.Text = "WHERE FROM?"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(8).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtHVACHours, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(9).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtSecurity, "")
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(10).Cells(2).Shape.TextFrame.TextRange.Text = "GetPlus15 Function!"
            objPPPresentation.Slides(intSlide).Shapes(intShapes).Table.Rows(11).Cells(2).Shape.TextFrame.TextRange.Text = Nz(Me.txtComments, "")

        Case Is = "pictureBuildingPhoto"
            imageWidth = GetGraphicWidthOrHeight(strExportFolder & strBuildingPhotoFileName, "Width")
            imageHeight = GetGraphicWidthOrHeight(strExportFolder & strBuildingPhotoFileName, "Height")
            ' The ratio of image Pixels vs. Shape sizes is.
            imageWidth = imageWidth * (71 / 96)
            imageHeight = imageHeight * (71 / 96)

            ' Can't change the image of a picture object so this Shape has been removed from the Template
            Set pptShape = objPPPresentation.Slides(intSlide).Shapes(intShapes)

            Top = objPPPresentation.Slides(intSlide).Shapes(intShapes).Top
            Left = objPPPresentation.Slides(intSlide).Shapes(intShapes).Left
            Height = objPPPresentation.Slides(intSlide).Shapes(intShapes).Height
            Width = objPPPresentation.Slides(intSlide).Shapes(intShapes).Width
            pptShape.Delete

            If imageHeight > imageWidth Then
                Left = Left + ((Width / 2) - (imageWidth / 2))
                objPPPresentation.Slides(intSlide).Shapes.AddPicture strExportFolder & strBuildingPhotoFileName, msoFalse, msoCTrue, _
                Left, Top, -1, Height
            Else
                'Adjust Top value so the image in centered
                Top = Top + ((Height / 2) - (imageHeight / 2))
                objPPPresentation.Slides(intSlide).Shapes.AddPicture strExportFolder & strBuildingPhotoFileName, msoFalse, msoCTrue, _
                Left, Top, Width, -1
            End If

    End Select

    intShapes = intShapes + 1
Loop

Jamie Garroch - MVP Jamie Garroch - MVP · Accepted Answer · 2015-11-04T08:36:45

You can also use the For Each structure to loop through a Collection e.g.

Dim oShp As Shape
Dim oSld As Slide
For Each oShp In oSld.Shapes
  ' Do suff
Next

But you mentioned the critical word "Delete".

If you are deleting any object in a Collection that you are looping through in VBA, you MUST loop backwards!

So, use this instead:

Dim intLoop As Integer
For intLoop = objPPPresentation.Slides(1).Shapes.Count to 1 Step -1

PowerPoint Shape not in the Shape Collection

1 Answers