分享一个按照固定单位调整 Powerpoint 圆角矩形的 VB 代码

[HOMO114514]

Powerpoint 的圆角矩形，调整 Border Radius 的单位是相对于形状本体尺寸的百分比。

如果想要用一个绝对单位去控制其圆角大小，使得任意尺寸的矩形圆角都一致的话，需要通过简单的单位换算，求得目标 pt 与短边之间相对的百分比，并将这个数值应用到形状上。

代码由 GPT 辅助生成。

Sub SetRoundedAndTopRoundedCorners()
    Dim selectedShape As Shape
    Set selectedShape = ActiveWindow.Selection.ShapeRange(1)
    
    ' Dim adj As Adjustments
    Set selectedShapeAdj = selectedShape.Adjustments
    
    ' 输入您想要的固定圆角磅值
    Dim fixedRadiusPoints As Double
    fixedRadiusPoints = 8 ' 您可以根据需要进行调整
    
    ' 获取矩形的宽度和高度
    Dim rectWidth As Double
    Dim rectHeight As Double
    rectWidth = selectedShape.Width
    rectHeight = selectedShape.Height
    
    ' 获取矩形的短边
    Dim shortSide As Double
    If rectWidth <= rectHeight Then
        shortSide = rectWidth
    Else
        shortSide = rectHeight
    End If
    
    ' 计算比例
    Dim scaleFactor As Double
    scaleFactor = fixedRadiusPoints / shortSide
    
    ' 设置圆角大小
    If selectedShape.AutoShapeType = msoShapeRoundedRectangle Then
        ' 圆角矩形
        selectedShape.Adjustments.Item(1) = scaleFactor
    ElseIf selectedShape.AutoShapeType = msoShapeRound2SameRectangle Then
        ' 圆顶角矩形
        selectedShape.Adjustments.Item(1) = scaleFactor
        selectedShape.Adjustments.Item(2) = 0
    End If
End Sub

使用方法：

1. 启动“开发工具”选项卡，在“Virtual Basic”中新建一个模块，粘贴上述代码，修改fixedRadiusPoints为目标值
2. 选中一个圆角矩形，运行该代码

缺点：

暂不支持批量选择，每次只能修改一个圆角矩形