VBA能否调用PowerPoint内置插入矩形功能，支持用户鼠标调整位置尺寸？

方案1：调用内置插入矩形UI+事件监听（推荐，完全匹配需求） #

PowerPoint VBA可通过CommandBars.ExecuteMso调用内置插入矩形命令，配合应用级事件监听实现「交控制权给用户绘制矩形，完成后自动回到代码逻辑」的效果，实现步骤如下：

步骤1：创建事件监听类模块 #

在VBA编辑器中插入类模块，将模块重命名为clsInsertRectListener，粘贴以下代码：

Public WithEvents pptApp As Application
Public targetPic As Shape ' 存储预先选中的原始图片
Public isWaitingForRect As Boolean ' 标记是否在等待用户插入矩形

Private Sub pptApp_NewShape(ByVal Shp As Shape)
    If Not isWaitingForRect Then Exit Sub
    If Shp.Type <> msoAutoShape Or Shp.AutoShapeType <> msoShapeRectangle Then Exit Sub
    
    ' 读取用户绘制的矩形参数
    Dim rectLeft As Single, rectTop As Single, rectW As Single, rectH As Single
    rectLeft = Shp.Left
    rectTop = Shp.Top
    rectW = Shp.Width
    rectH = Shp.Height
    
    ' 计算裁剪参数并执行裁剪
    With targetPic
        .PictureFormat.CropLeft = rectLeft - .Left
        .PictureFormat.CropTop = rectTop - .Top
        .PictureFormat.CropRight = .Left + .Width - (rectLeft + rectW)
        .PictureFormat.CropBottom = .Top + .Height - (rectTop + rectH)
    End With
    
    ' 可选：删除用户绘制的辅助矩形
    Shp.Delete
    
    ' 重置监听状态
    isWaitingForRect = False
    Set pptApp = Nothing
    Set targetPic = Nothing
    MsgBox "图片裁剪完成", vbInformation
End Sub

步骤2：创建标准模块执行主逻辑 #

插入标准模块，粘贴以下代码：

Dim listener As clsInsertRectListener

Sub CropPicByUserDrawRect()
    ' 校验是否选中有效图片
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then
        MsgBox "请先选中需要裁剪的图片", vbExclamation
        Exit Sub
    End If
    If ActiveWindow.Selection.ShapeRange(1).Type <> msoPicture Then
        MsgBox "选中的对象不是图片", vbExclamation
        Exit Sub
    End If
    
    ' 初始化监听器，存储目标图片
    Set listener = New clsInsertRectListener
    Set listener.pptApp = Application
    Set listener.targetPic = ActiveWindow.Selection.ShapeRange(1)
    listener.isWaitingForRect = True
    
    ' 触发内置插入矩形命令，控制权转交给用户
    Application.CommandBars.ExecuteMso "ShapeRectangle"
    ' 用户绘制完成后会自动触发类模块的NewShape事件执行裁剪逻辑
End Sub

注意事项 #

• 若用户按ESC取消插入矩形，不会触发后续裁剪逻辑，无副作用
• 裁剪计算规则可根据实际需求调整

方案2：轻量交互方案（无需事件监听） #

如果不想使用类模块事件，可通过简化交互逻辑实现，适合对代码复杂度要求低的场景：

Sub CropPicByUserDrawRect_Simple()
    ' 校验选中的图片
    If ActiveWindow.Selection.Type <> ppSelectionShapes Or ActiveWindow.Selection.ShapeRange(1).Type <> msoPicture Then
        MsgBox "请先选中需要裁剪的图片", vbExclamation
        Exit Sub
    End If
    Dim targetPic As Shape
    Set targetPic = ActiveWindow.Selection.ShapeRange(1)
    
    ' 记录当前页面形状总数，用于后续检测新增矩形
    Dim preShapeCount As Long
    preShapeCount = ActiveWindow.View.Slide.Shapes.Count
    
    ' 触发插入矩形命令
    Application.CommandBars.ExecuteMso "ShapeRectangle"
    MsgBox "请在页面上绘制裁剪区域矩形，绘制完成后点击确定", vbInformation
    
    ' 校验是否新增了矩形
    If ActiveWindow.View.Slide.Shapes.Count <= preShapeCount Then
        MsgBox "未检测到新插入的矩形", vbExclamation
        Exit Sub
    End If
    Dim newShp As Shape
    Set newShp = ActiveWindow.View.Slide.Shapes(ActiveWindow.View.Slide.Shapes.Count)
    If newShp.Type <> msoAutoShape Or newShp.AutoShapeType <> msoShapeRectangle Then
        MsgBox "新增对象不是矩形", vbExclamation
        Exit Sub
    End If
    
    ' 执行裁剪
    With targetPic
        .PictureFormat.CropLeft = newShp.Left - .Left
        .PictureFormat.CropTop = newShp.Top - .Top
        .PictureFormat.CropRight = .Left + .Width - (newShp.Left + newShp.Width)
        .PictureFormat.CropBottom = .Top + .Height - (newShp.Top + newShp.Height)
    End With
    newShp.Delete
    MsgBox "裁剪完成", vbInformation
End Sub

内容的提问来源于stack exchange，提问作者K ATL