将图像裁剪为具有 1:1 纵横比的圆形

Question

我正在尝试获取一个脚本，它将以 1:1 的纵横比裁剪图像，下面是我正在尝试的脚本，但它被裁剪为椭圆形。

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

谁能帮帮我。

提前致谢。

Answer 1

您选择的任何裁剪形状的尺寸取决于原始形状。如果您有一个正方形并应用msoShapeOval，您的裁剪区域将是一个圆形。但是，如果您的原始图像形状是矩形，您有两种选择：

1. 如果形状的.LockAspectRatio 是msoFalse，那么您可以修改宽度或高度以创建一个正方形图像，然后应用您的裁剪，它会变成一个圆形。
2. 如果形状的 .LockAspectRatio 是 msoTrue 并且您无法更改它（即，它会以不希望的方式扭曲原始图像），那么您需要一种不同的方法。

从演示文稿中的单个幻灯片和幻灯片上的单个（图像）形状开始

这个想法是添加一个与原始图像相同大小（宽度和高度）的矩形，然后在矩形顶部创建一个您需要的大小（直径）的圆圈。在下面的示例中，我使用的（随机）圆形大小为原始图像高度的 80%。然后，将两个形状（矩形和圆形）组合成一个形状——一个中间有一个洞的矩形。最后，将遮罩形状的背景和边框颜色设置为与幻灯片背景相同。

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

结果如下：

显然，这不是真正的裁剪，只是一个近似值，只有在幻灯片背景是纯色（不是图案或渐变）时才有效。

Answer 2

与其他替代方案相比，这种方法要简单得多。

// 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;
}