圆角应该在 Powerpoint VBA 脚本中保持不变

Question

我正在处理下面给定的脚本以将所有角转换为圆角，但圆角并未为所有形状提供相同的值。

我已经完成了以下脚本

Sub RoundedCorner5()


    Dim oShape As Shape
Dim sngRadius As Single ' Radius size in points

sngRadius = 0.05
For Each oShape In ActiveWindow.Selection.ShapeRange

    With oShape
         oShape.AutoShapeType = msoShapeRoundedRectangle
         oShape.TextFrame.WordWrap = msoFalse
         oShape.TextEffect.Alignment = msoTextEffectAlignmentCentered
        .Adjustments(1) = sngRadius
    End With
Next
Set oShape = Nothing

End Sub

假设我有一个小矩形和一个大矩形，两种形状的圆角值都不同

Answer 1

默认情况下，圆角与形状大小成比例。这是微软关于调整的页面，请注意单位不是点数：Adjustments object (PowerPoint)

此代码应该让您非常接近，更改 RadiusFactor 以获得您喜欢的角尺寸：

Sub RoundedCorner5()
  Dim oShape As Shape
  Dim RadiusFactor As Single
  RadiusFactor = 50
  For Each oShape In ActiveWindow.Selection.ShapeRange
    With oShape
      .AutoShapeType = msoShapeRoundedRectangle
      .Adjustments(1) = (1 / (oShape.Height + oShape.Width)) * RadiusFactor
      .TextFrame.WordWrap = msoFalse
      .TextEffect.Alignment = msoTextEffectAlignmentCentered
    End With
  Next
End Sub

Answer 2

以下代码非常适合这项工作。全部归功于：Rembrandt Kuipers 代码所在站点：https://www.brandwares.com/bestpractices/2019/09/uniform-rounded-corners-cool-code/

Sub RoundAllPPCorners()
  Dim oSlide As Slide, oShape As Shape, RadiusFactor!

  RadiusFactor! = 5
  For Each oSlide In ActivePresentation.Slides
  For Each oShape In oSlide.Shapes
      With oShape
        If .AutoShapeType = msoShapeRoundedRectangle Then
          minDim = oShape.Height
          If oShape.Width < oShape.Height Then
            minDim = oShape.Width
          End If
          .Adjustments(1) = (1 / minDim) * RadiusFactor!
        End If
      End With
    Next oShape
  Next oSlide
End Sub

圆角应该在 Powerpoint VBA 脚本中保持不变

Rounded Corner Should be constant in Powerpoint VBA script

powerpoint

vba