圆角在 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

默认情况下，圆角与形状尺寸成比例。这是微软关于调整的页面，请注意单位不是点：调整对象（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

Answer 3

这是我的版本——我花了太长时间才做出来。它是该线程中其他答案的合并，具有以下功能：

• 仅设置圆角矩形上的角半径，不影响其他形状
• 半径将完全独立于形状的宽度/高度比
• 适用于在所有选定形状上选择的多个形状
• 适用于分组形状，并将设置分组形状内所有圆角矩形的角半径（如果有）
• 如果未选择任何内容（或没有选择任何合适的内容），则默默退出

    Sub RoundedCorner()
      Dim oShape As Shape
      Dim RadiusFactor As Single
      RadiusFactor = 5
      
      ' If nothing is selected exit
      If ActiveWindow.Selection.Type <> ppSelectionShapes Then
        Exit Sub
      End If
      
      For Each oShape In ActiveWindow.Selection.ShapeRange
         If oShape.Type = msoGroup Then
           ' Loop through each sub-shape in the group
             For Each oSubShape In oShape.GroupItems
               If oSubShape.AutoShapeType = msoShapeRoundedRectangle Then
                 oSubShape.Adjustments(1) = (1 / GetMinDim(oSubShape)) * RadiusFactor
               End If
             Next oSubShape
          Else
            ' Handle non-group shapes
            If oShape.AutoShapeType = msoShapeRoundedRectangle Then
              oShape.Adjustments(1) = (1 / GetMinDim(oShape)) * RadiusFactor
            End If
          End If
        Next oShape
    End Sub
    
    Function GetMinDim(ByVal oShape As Shape) As Single
        ' Check if the width or height is smaller and return the smaller value
        If oShape.Width < oShape.Height Then
            GetMinDim = oShape.Width
        Else
            GetMinDim = oShape.Height
        End If
    End Function

希望对某人有帮助！ ...而且它的价值在于：VBA 确实需要提高其性能 - 这太糟糕了。