Consulting

Results 1 to 10 of 10

Thread: Loop Through Collection to Delete all But one msoPicture Help

  1. #1
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location

    Loop Through Collection to Delete all But one msoPicture Help

    Greeting PPT gurus:

    I'm working on a PPT macro to go through slides 2&3 and loop through the collection to delete the last msoPicture on the slide (the last screen shot from the night before).

    This is the code I use for my report:
    Sub Daily_Report()
    
    Dim opic As Shape
    Dim nn As Integer
    Dim sldHeight As Single
    Dim sldWidth As Single
    
    
    'Setup changes for slides 2-3
    For nn = 2 To 3
    For Each opic In ActivePresentation.Slides(nn).Shapes
    If opic.Type = msoPicture Then
    
    
    With ActivePresentation.PageSetup
     sldWidth = .SlideWidth
     sldHeight = .SlideHeight
    End With
    
    
    'Resize and position images for curtain section
    With opic
    .LockAspectRatio = msoFalse
    .Height = sldHeight * 0.817778
    .Width = sldWidth * 0.98
    .Left = sldWidth * 0.01
    .Top = sldHeight * 0.017778
    .ZOrder (msoSendTofront)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    Else 'do nothing
    End If
    Next opic
    Next
    
    
    'Move Line
    For Each opic In ActivePresentation.Slides(2).Shapes
    If opic.Type = msoLine Then
    With opic
    .LockAspectRatio = msoFalse
    .Left = sldWidth * 0.015
    .ZOrder (msoSendToBack)
    .Line.Weight = 1.5
    .Line.ForeColor.RGB = RGB(255, 0, 0)
    End With
    Else 'do nothing
    End If
    Next opic
    
    
    'Delete old screenshot
    With Application.ActivePresentation.Slides(nn).Shapes
        For intShape = .Count To 1 Step -1
            With .Item(intShape)
                If .Type = msoPicture Then .Delete
            End With
        Next
    End With
    
    
    'Updates links in Powerpoint
    Dim osld As Slide
    For Each osld In ActivePresentation.Slides
    For Each opic In osld.Shapes
    If opic.Type = msoLinkedOLEObject Then opic.LinkFormat.Update
    Next opic
    Next osld
    
    
    End Sub
    Currently the 'Delete old screenshot is giving me:
    "Run-time error '-2147188160 (80048240)':
    Slides (unkown member) : Integer out of range. 4 is not in the valid range of 1 to 3."

  2. #2
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    So I'm still struggling to understand how to get VBA to resolve the issue. I have tried the following, but it deletes everything, rather than all but the first msoPicture. Anyone have any suggestions?
    'Delete Shapes
    For Each opic In ActivePresentation.Slides(2).Shapes
    If opic.Type = msoPicture Then
          While ActivePresentation.Slides(2).Shapes.Count > 1
                ActivePresentation.Slides(2).Shapes(1).Delete
          Wend
    End If
    Next

  3. #3
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,862
    Location
    Try something like this:

    'Delete old screenshot
    
    With Application.ActivePresentation.Slides(nn).Shapes
        For intshape = .Count To 1 Step -1
            With .Item(intshape)
                If .Type = msoPicture Then
                .Delete
                'jump out of loop to leave any other pics
                Exit For
                End If
            End With
        Next intshape
    End With
    Also there is no constant msoSendToFront it is msoBringToFront

    Also If the picture is in a placeholder it's type will NOT be msoPicture. You should check for a Placeholder and then its ContainedType
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  4. #4
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    Thanks for your reply John, though when I used it, it still didn't quite work. Here's the results:
    PreMacro.jpgPostMacro.jpg
    It deleted the picture I was wanting to keep in the front (Picture 6) and moved the back picture I'm trying to delete (Picture 5) to the front. I need it to always skip Pic 6, and delete the image following it (whether it be in the second position or the last position, or just pass over this part of the code if there is no picture the one that was just brought in).

  5. #5
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,862
    Location
    I guess it's clear to you what you are trying to do but you need to explain more clearly preferably with before and after slide examples. The last added picture would normally be at the front but you seem to be trying to delete pictures further back??
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  6. #6
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    Sorry John, I'm fairly new with macros in PPT, I'll keep that in mind next time. Yes sir, I'd like for the macro to be able to take either of the cases below:
    PreMacro.jpgPreMacro2.jpg
    In the examples above, I have Picture 6 as the new picture I need resized and want to keep, and Picture 5 was the previous report's image that needs to be removed.


    The end result should be as follows:
    PostMacro.jpg

  7. #7
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,862
    Location
    So maybe:

    Sub deletePic()
    Dim osld As Slide
    Dim L As Long
    Dim P As Long
    Dim SldHeight As Long
    Dim SldWidth As Long
    
    
    With ActivePresentation.PageSetup
     SldWidth = .SlideWidth
     SldHeight = .SlideHeight
    End With
    
    
    For L = 2 To 3
    Set osld = ActivePresentation.Slides(L)
    With osld
    ' remove old
    For P = 1 To .Shapes.Count
    If osld.Shapes(P).Type = msoPicture Then
    osld.Shapes(P).Delete
    Exit For
    End If
    Next P
    
    
    For P = .Shapes.Count To 1 Step -1
    If osld.Shapes(P).Type = msoPicture Then
    With osld.Shapes(P)
    .LockAspectRatio = msoFalse
    .Height = SldHeight * 0.817778
    .Width = SldWidth * 0.98
    .Left = SldWidth * 0.01
    .Top = SldHeight * 0.017778
    .ZOrder (msoBringToFront)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    Exit For
    End If
    Next P
    
    
    End With
    Next L
    End Sub
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  8. #8
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    That works great! The only problem I encountered is when the image in the back is already deleted, it'll delete the one I put in. Is there a way to add a function to that where if there are two msoPictures in the slide, it will run the code you provided; if there's only one, then just do the resize portion? So for example, if I start with:
    PostMacro.jpg
    It will skip the delete step as there is only one picture present in the slide, and will move to the resize part, resulting with:
    PostMacro.jpg
    Thanks again for all the help John!

  9. #9
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,862
    Location
    You just need a function to count the pictures

    Sub deletePic()
    Dim osld As Slide
    Dim L As Long
    Dim P As Long
    Dim SldHeight As Long
    Dim SldWidth As Long
    
    With ActivePresentation.PageSetup
     SldWidth = .SlideWidth
     SldHeight = .SlideHeight
    End With
    
    For L = 2 To 3
    Set osld = ActivePresentation.Slides(L)
    With osld
    ' remove old
    If PicCount(osld) = 2 Then
    For P = 1 To .Shapes.Count
    If osld.Shapes(P).Type = msoPicture Then
    osld.Shapes(P).Delete
    Exit For
    End If
    Next P
    End If
    
    For P = .Shapes.Count To 1 Step -1
    If osld.Shapes(P).Type = msoPicture Then
    With osld.Shapes(P)
    .LockAspectRatio = msoFalse
    .Height = SldHeight * 0.817778
    .Width = SldWidth * 0.98
    .Left = SldWidth * 0.01
    .Top = SldHeight * 0.017778
    .ZOrder (msoBringToFront)
    .Line.Weight = 1
    .Line.ForeColor.RGB = RGB(99, 102, 106)
    End With
    Exit For
    End If
    Next P
    End With
    Next L
    End Sub
    
    Function PicCount(osld As Slide) As Long
    Dim opic As Shape
    For Each opic In osld.Shapes
    If opic.Type = msoPicture Then PicCount = PicCount + 1
    Next opic
    End Function
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  10. #10
    VBAX Regular
    Joined
    Jun 2019
    Posts
    44
    Location
    Once again, thanks John, you certainly are a wiz with excel.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •