PowerPoint宏开发需求：将所有矩形调整为选中首个形状的尺寸

你需要的宏核心逻辑很简单——直接取选中的第一个形状的尺寸作为标准，批量应用到其他选中的矩形上，不需要找最小尺寸的步骤。以下是修改后的完整代码：

Sub ResizeToFirstSelected()
    ' 定义变量
    Dim sngBaseWidth As Single
    Dim sngBaseHeight As Single
    Dim oSh As Shape
    Dim selShapes As ShapeRange
    
    ' 检查是否有选中的形状
    On Error Resume Next
    Set selShapes = ActiveWindow.Selection.ShapeRange
    On Error GoTo 0
    
    If selShapes Is Nothing Or selShapes.Count < 2 Then
        MsgBox "请至少选中2个形状！", vbExclamation
        Exit Sub
    End If
    
    ' 取第一个选中形状的尺寸作为基准
    With selShapes.Item(1)
        sngBaseWidth = .Width
        sngBaseHeight = .Height
    End With
    
    ' 遍历所有选中形状，调整尺寸
    For Each oSh In selShapes
        ' 可选：只调整矩形类形状（如果需要过滤非矩形）
        If oSh.Type = msoRectangle Then
            oSh.Width = sngBaseWidth
            oSh.Height = sngBaseHeight
        End If
    Next oSh
    
    MsgBox "已完成尺寸统一调整！", vbInformation
End Sub

关键改动说明： #

• 移除了原有代码中寻找最小尺寸的循环逻辑，直接复用第一个选中形状的宽高作为基准
• 增加了错误检查：判断是否有选中形状、选中数量是否足够，避免空选时报错
• 可选添加了矩形过滤：只调整类型为msoRectangle的形状，如果你需要调整所有选中形状（不管类型），可以删掉If oSh.Type = msoRectangle Then和对应的End If

使用方法： #

1. 打开PowerPoint，按Alt + F11打开VBA编辑器
2. 插入新模块：右键点击左侧项目窗格的演示文稿名称 → 插入 → 模块
3. 将上述代码粘贴到模块中
4. 返回PowerPoint，选中需要调整的形状（第一个选中的就是基准）
5. 按Alt + F8，选择ResizeToFirstSelected宏执行即可

内容的提问来源于stack exchange，提问作者Christian Moeller