vba - 使用 1 :1 aspect ratio 将图像裁剪为圆形

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

结果如下所示:

显然，这不是真正的裁剪，而只是一个近似值，并且仅当您的幻灯片背景为纯色(不是图案或渐变)时才有效。