Crop Image to circle shape with 1:1 aspect ratio - vba

Question

Am trying to get a script which will crop image in a circle shape with aspect ratio 1:1, below are the script I am trying but it's cropping in oval shape.
Sub CropToCircle()
Dim shp As Shape
Set shp = ActivePresentation.Slides(1).Shapes(1)
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
shp.AutoShapeType = msoShapeOval
End If
End Sub
Can anyone please help me in this.
Thanks in advance.

Answer 1

The dimensions of the whatever crop shape you choose are dependent on the original shape. If you have a square shape and apply msoShapeOval, your crop area will be a circle. But if your original image shape is rectangular you have two options:
If the .LockAspectRatio of the shape is msoFalse, then you can modify the width or height to create a square image, then apply your crop and it will come out as a circle.
If the .LockAspectRatio of the shape is msoTrue and you can't change it (i.e. it would distort the original image in an undesireable way), then you need a different approach.
Starting out with a single slide in a presentation and a single (image) shape on the slide
The idea is to add a rectangle overlaid in the same size (width and height) as the original image, then create a circle on top of the rectangle in the size (diameter) you need. In the example below, I'm using a (random) circle size of 80% of the height of the original image. Then, combine the two shapes (rectangle and circle) into a single shape -- a rectangle with a hole in the middle. Finally, set the background and border colors of the mask shape to be the same as the slide background.
Option Explicit
Sub CropToCircle()
Dim ppt As Presentation
Set ppt = ActivePresentation
Dim theSlide As Slide
Set theSlide = ppt.Slides(1)
Dim ogPicture As Shape
Set ogPicture = theSlide.Shapes(1)
With ogPicture
If (.Type = msoLinkedPicture) Or (.Type = msoPicture) Then
Dim maskRectangle As Shape
Dim maskCircle As Shape
Set maskRectangle = theSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
'--- randomly decided the circle mask should be 80% of the
' height of the original image
Const MASK_SIZE As Double = 0.8
Dim circleDiameter As Double
circleDiameter = .Height * MASK_SIZE
Set maskCircle = theSlide.Shapes.AddShape(Type:=msoShapeOval, _
Left:=(.Left + ((.Width / 2) - (circleDiameter / 2))), _
Top:=(.Top + (.Height * ((1# - MASK_SIZE) / 2#))), _
Width:=circleDiameter, _
Height:=circleDiameter)
Dim maskShapes As Variant
maskShapes = Array(maskRectangle.Name, maskCircle.Name)
theSlide.Shapes.Range(maskShapes).MergeShapes msoMergeCombine
'--- find the shape we just created
Dim maskShape As Shape
For Each maskShape In theSlide.Shapes
If maskShape.Name <> .Name Then
Exit For
End If
Next maskShape
'--- the color of the new make shape and it's border has to match
' the color of the slide background, assuming it's solid
maskShape.Fill.ForeColor = theSlide.Background.Fill.BackColor
maskShape.Line.ForeColor = theSlide.Background.Fill.BackColor
'--- optionally group the mask and the original image
theSlide.Shapes.Range(Array(.Name, maskShape.Name)).Group
End If
End With
End Sub
The result looks like this:
Clearly, this is not a true crop and only an approximation and will only work if your slide background is a solid color (not a pattern or gradient).

Answer 2

This approach would be much more simple compared to other alternatives.
// Crop 1:1
shape.Select();
CommandBars.ExecuteMso("PictureCropAspectRatio1To1");
// To convert to oval
if (shape.AutoShapeType != MsoAutoShapeType.msoShapeOval &&
shape.Type == MsoShapeType.msoPicture)
{
shape.AutoShapeType = MsoAutoShapeType.msoShapeOval;
}