循环浏览选定的幻灯片并删除已命名的形状

Question

我正在尝试为 PowerPoint 创建 "sticker" 宏。简而言之，我有一个按钮，用 "Done" 的形状标记选定的幻灯片。这个宏正在运行。但是，我还需要一个宏来删除所选幻灯片上的完成标签。如果只选择一张幻灯片，我现在所拥有的可以删除形状。我对 PowerPoint 中的 VBA 很陌生。

添加贴纸宏（有效）：

Sub StickerDone()

Dim StickerText As String
Dim sld As Slide

StickerText = "Done"

Dim shp As Shape

For Each sld In ActiveWindow.Selection.SlideRange

'Create shape with Specified Dimensions and Slide Position
    Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, _
        Left:=0 * 28.3464567, Top:=0 * 28.3464567, Width:=80, Height:=26.6)

'FORMAT SHAPE
    'Shape Name
        shp.Name = "StickerDone"

    'No Shape Border
        shp.Line.Visible = msoFalse

    'Shape Fill Color
        shp.Fill.ForeColor.RGB = RGB(56, 87, 35)

    'Shape Text Color
        shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)

    'Text inside Shape
        shp.TextFrame.TextRange.Characters.Text = StickerText

    'Center Align Text
        shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter

    'Vertically Align Text to Middle
        shp.TextFrame2.VerticalAnchor = msoAnchorMiddle

    'Adjust Font Size
        shp.TextFrame2.TextRange.Font.Size = 14

    'Adjust Font Style
        shp.TextFrame2.TextRange.Font.Name = "Corbel"

    'Rotation
        shp.Rotation = 0

Next sld

End Sub

删除贴纸宏（无效）：

Sub StickerDelete()

    Dim shp As Shape
    Dim sld As Slide

    For Each sld In ActiveWindow.Selection.SlideRange
        For Each shp In sld.Shapes
            If shp.Name Like "StickerDone" Then

                shp.Select
                shp.Delete

            End If

        Next shp

    Next sld

End Sub

Answer 1

删除正在迭代的对象通常不是一个好主意。将它们添加到数组并在（内部）循环完成后删除它们。

试试这个：

Sub StickerDelete()

    Dim shp As Shape
    Dim sld As Slide

    ReDim ShapesToDelete(0)
    Dim ShapeCount

    For Each sld In ActiveWindow.Selection.SlideRange
        For Each shp In sld.Shapes
            If shp.Name Like "StickerDone" Then

                'shp.Select
                'shp.Delete
                ShapeCount = ShapeCount + 1
                ReDim Preserve ShapesToDelete(0 To ShapeCount)
                Set ShapesToDelete(ShapeCount) = shp

            End If

        Next shp

    Next sld

    For i = 1 To ShapeCount
        ShapesToDelete(i).Delete
    Next
End Sub

循环浏览选定的幻灯片并删除已命名的形状

Loop through selected slides and delete namned shape

powerpoint

vba