Create Macro to Crop Multiple Pictures

[wmc1956]

I have a PowerPoint file that has numerous pictures that need cropped. Could somebody please give me the code to create a macro to crop all these pictures at one time? I have the code to crop one picture at a time in Word, but I don't know how to write it for PowerPoint and to do multiple pictures at one time. This is the code I have:

Sub CropDemo()
Dim oILS As InlineShape
Set oILS = Selection.InlineShapes(1)
With oILS
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = 30
End With
With oILS
.LockAspectRatio = False
.Height = 265
End With
lbl_Exit:
Exit Sub
End Sub

[John Wilson]

Something like this maybe:


Sub CropPic()
Dim oshp As Shape
Dim osld As Slide
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If isPic(oshp) Then
With oshp
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = 30
.LockAspectRatio = False
.Height = 265
End With
End If
Next oshp
Next osld
End Sub


Function isPic(oshp As Shape) As Boolean
If oshp.Type = msoPicture Then
isPic = True
Exit Function
End If
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoPicture Then
isPic = True
Exit Function
End If
End If
End Function

Be aware that setting LockAspectRatio to False may distort images.

[wmc1956]

Thank you SO much! I tweaked it a little bit through trial and error to get it where it needed to be, but otherwise it worked great! Is it possible to add some code in to position it on the slide?

[John Wilson]

That should be fairly easy but you should say what position (from top left) you need. I presume you work in inches in Ohio.