Обрезать изображение до формы круга с соотношением сторон 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, ваша область обрезки будет кругом. Но если исходная форма изображения прямоугольная angular, у вас есть два варианта:

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

Результат выглядит следующим образом:

Очевидно, что это не настоящая обрезка, а только приближение, и она будет работать только в том случае, если фон слайда имеет цвет solid (а не узор или градиент).