vba - 以与 autoshape 下拉菜单类似的方式创建形状

Question

我想在 Powerpoint 中创建一个宏，使我能够以与您在自选图形概览中选择自选图形时类似的方式创建形状（即，一旦您调用宏，您就可以单击以设置坐标，然后拖动并单击以设置宽度和高度）。另外，我想给它预设的外观特征（例如某些内边距、填充颜色、边框样式和透明度），这些特征将在 vba 代码中定义。

我知道 .addshapes()，但是，这需要坐标和高度/宽度作为输入。此外，我还没有在 vba 上找到任何帖子/文档来创建没有定义坐标和高度/宽度的形状。有人对如何应对这一挑战有任何想法吗？

提前谢谢了！

至今

标签： vbapowerpoint

Answer 1

我对这个问题很着迷，并认为这可能会对你有所帮助。

考虑到当您绘制一个新的自选图形时，您已经更改了窗口选择，并创建了一个新的选择 ShapeRange，其中正好有 1 个项目（新形状）。

因此，通过设置 WindowSelectionChange 事件，您可以在创建时应用您希望的任何格式。

首先使用以下内容创建一个名为 cPptEvents 的类模块：

Public WithEvents PPTEvent As Application

Private Sub PPTEvent_WindowSelectionChange(ByVal sel As Selection)
    On Error GoTo Errhandler
    Debug.Print "IN_PPTEvent_WindowSelectionChange"

    Dim oShp As Shape

    If (ActiveWindow.ViewType = ppViewNormal) Then
        With sel
            If .Type = ppSelectionShapes Then
                If .ShapeRange.Count = 1 Then
                    Set oShp = .ShapeRange(1)
                    If oShp.Type = msoAutoShape Then
                        If oShp.AutoShapeType = msoShapeOval Then
                           If oShp.Tags("new_oval") = "" Then
                                oShp.Fill.ForeColor.RGB = RGB(255, 0, 0)
                                oShp.Tags.Add "new_oval", "true"
                            End If
                        End If
                    End If
                End If
            End If
        End With

    End If



    Exit Sub

Errhandler:
    Debug.Print "Error: " & Err.Description

End Sub

每次更改时都会检查选择。如果选择了一个椭圆，它会查找“new_oval”标签，新创建的形状不存在该标签。在这种情况下，它会应用红色填充，当然，一旦你到了这一点，你就可以调用一个完全不同的 sub，传递形状，然后对它进行任何你想要的格式化操作。

通过添加“new_oval”标签，您可以确保格式不会应用于尚未新建的椭圆。这允许用户根据需要手动更改格式 - 否则每次用户选择椭圆时您只是重置格式。

请注意，要在后台运行 _WindowSelectionChange 事件，您必须在某些时候调用它：

Public MyEventClassModule As New cPptEvents

'
Public Sub StartMeUp()
   Set MyEventClassModule.PPTEvent = Application
End Sub

如果您正在制作新的插件功能区，则可以在插件触发的任何 Ribbon_Onload 子中包含上述 StartMeUp 中的一行。

使用此解决方案，您甚至不必为最终用户提供特殊按钮或工具集来创建正在格式化的形状。每当用户从本机 PPT 工具绘制新形状时，它都会无形地发生。