Vba 找到下一个带有特殊标记的形状

为了与一群人进行内部交流，我创建了一个宏，将注释字段添加到幻灯片中，而不是PPT本身

    Dim shp As Shape
    Dim sld As Slide
    'Comment field

On Error GoTo ErrMsg

If ActiveWindow.Selection.SlideRange.Count <> 1 Then
        MsgBox "This function cannot be used for several slides at the same time"
        Exit Sub
    Else

    Set sld = Application.ActiveWindow.View.Slide
    Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=0, Top:=104.88182, Width:=198.42507, Height:=28.913368)
    shp.Fill.Visible = msoTrue
    shp.Fill.Transparency = 0
    shp.Fill.ForeColor.RGB = RGB(211, 61, 95)
    shp.Line.Visible = msoTrue
    shp.Line.ForeColor.RGB = RGB(255, 255, 255)
    shp.Line.Weight = 0.75
    shp.Tags.Add "COMMENT", "YES"
    shp.Select

    shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
    shp.TextFrame.TextRange.Characters.Text = "Comment: "
    shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
    shp.TextFrame.VerticalAnchor = msoAnchorTop
    shp.TextFrame.TextRange.Font.Size = 12
    shp.TextFrame.TextRange.Font.Name = "Arial"
    shp.TextFrame.TextRange.Font.Bold = msoTrue
    shp.TextFrame.TextRange.Font.Italic = msoFalse
    shp.TextFrame.TextRange.Font.Underline = msoFalse
    shp.TextFrame.Orientation = msoTextOrientationHorizontal
    shp.TextFrame.MarginBottom = 7.0866097
    shp.TextFrame.MarginLeft = 7.0866097
    shp.TextFrame.MarginRight = 7.0866097
    shp.TextFrame.MarginTop = 7.0866097
    shp.TextFrame.WordWrap = msoTrue
    shp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
    shp.TextFrame.TextRange.Select

    End If
Exit Sub

ErrMsg:
    MsgBox "Please select a slide"
End Sub

将shp尺寸设置为形状
将sld变暗为幻灯片
'注释字段
关于错误转到ErrMsg
如果ActiveWindow.Selection.SlideRange.Count为1，则
MsgBox“此功能不能同时用于多张幻灯片”
出口接头
其他的
设置sld=Application.ActiveWindow.View.Slide
设置shp=sld.Shapes.AddShape（类型：=msoShapeRectangle，左侧：=0，顶部：=104.88182，宽度：=198.42507，高度：=28.913368）
shp.Fill.Visible=msoTrue
shp.Fill.Transparency=0
shp.Fill.ForeColor.RGB=RGB（211,61,95）
shp.Line.Visible=msoTrue
shp.Line.ForeColor.RGB=RGB（255、255、255）
shp.Line.Weight=0.75
shp.Tags.Add“COMMENT”，“YES”
选择
shp.TextFrame.TextRange.Font.Color.RGB=RGB（255、255、255）
shp.TextFrame.TextRange.Characters.Text=“注释：”
shp.TextFrame.TextRange.ParagraphFormat.Alignment=ppAlignLeft
shp.TextFrame.VerticalAnchor=msoAnchorTop
shp.TextFrame.TextRange.Font.Size=12
shp.TextFrame.TextRange.Font.Name=“Arial”
shp.TextFrame.TextRange.Font.Bold=msoTrue
shp.TextFrame.TextRange.Font.Italic=msoFalse
shp.TextFrame.TextRange.Font.Underline=msoFalse
shp.TextFrame.Orientation=msotextorientation卧式
shp.TextFrame.MarginBottom=7.0866097
shp.TextFrame.MarginLeft=7.0866097
shp.TextFrame.MarginRight=7.0866097
shp.TextFrame.MarginTop=7.0866097
shp.TextFrame.WordWrap=msoTrue
shp.TextFrame.AutoSize=ppAutoSizeShapeToFitText
shp.TextFrame.TextRange.Select
如果结束
出口接头
错误消息：
MsgBox“请选择一张幻灯片”
端接头

效果很好

我对它们进行了标记，因为我希望能够轻松地一次删除所有它们，例如，如果您在必须提交之前5分钟发现评论。以下是我删除它们的方法：

Sub CommDel()
    Dim sld As Slide
    Dim L As Long
    If MsgBox("Do you want to delete ALL comments from the entire presentation?", vbYesNo) <> vbYes Then Exit Sub
    On Error Resume Next
    For Each sld In ActivePresentation.Slides
        For L = sld.Shapes.Count To 1 Step -1
            If sld.Shapes(L).Tags("COMMENT") = "YES" Then sld.Shapes(L).Delete
        Next L
    Next sld
End Sub

子命令（）
将sld变暗为幻灯片
我和你一样长
如果MsgBox（“是否要删除整个演示文稿中的所有注释？”，vbYesNo）vbYes，则退出Sub
出错时继续下一步
对于ActivePresentation.Slides中的每个sld
对于L=sld.Shapes.Count到1步-1
如果sld.Shapes（L）.Tags（“COMMENT”）=“YES”，则sld.Shapes（L）.Delete
下一个L
下一个sld
端接头

也很好用

我想做的第三步是创建第三个宏，称为“查找下一个注释”。每次单击时，它都会跳转到下一个标记为“COMMENT”的形状，无论该形状是在同一张幻灯片上，还是在演示文稿中的下一张幻灯片上或其他地方。只是下一个，无论它在哪里。现在我完全迷路了。我可以在一张幻灯片上或整个演示文稿中对所有标记的形状执行某些操作—正如您在要删除的函数中看到的那样。但我要找的不是同时选择所有形状。在另一次尝试中，我找到了第一个形状，但再次单击宏后，似乎什么也没有发生，因为宏开始在同一点搜索，并一次又一次地选择同一形状，除了删除第一个形状外，从未跳到下一个形状

---

如果能读到你的想法就好了。先谢谢你。但要小心，我远不是一个好的程序员

这从当前幻灯片开始，一直持续到最后，一旦找到第一条注释，就会从Sub中退出：

Sub FindNextComment()
    Dim oSlide As Slide
    Dim oShape As Shape

    Set oSlide = ActiveWindow.View.Slide
    For Each oShape In oSlide.Shapes
        If oShape.Tags.Count > 0 Then
            For y = 1 To oShape.Tags.Count
                If oShape.Tags.Name(y) = "COMMENT" Then
                    oShape.Select
                    Exit Sub
                End If
            Next y
        End If
    Next oShape
    For x = oSlide.SlideIndex + 1 To ActivePresentation.Slides.Count
        For Each oShape In ActivePresentation.Slides(x).Shapes
            If oShape.Tags.Count > 0 Then
                For y = 1 To oShape.Tags.Count
                    If oShape.Tags.Name(y) = "COMMENT" Then
                        ActivePresentation.Slides(x).Select
                        oShape.Select
                        Exit Sub
                    End If
                Next y
            End If
        Next oShape
    Next x
End Sub

额外的VBA提示：通过使用With语句，您可以使代码运行得更快一些：

With shp.TextFrame
    .MarginBottom = 7.0866097
    .MarginLeft = 7.0866097
    .MarginRight = 7.0866097
    .MarginTop = 7.0866097
    .WordWrap = msoTrue
    .AutoSize = ppAutoSizeShapeToFitText
    .Orientation = msoTextOrientationHorizontal
    .VerticalAnchor = msoAnchorTop
    With .TextRange
        .Characters.Text = "Comment: "
        .Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
        With .Font
            .Size = 12
            .Name = "Arial"
            .Bold = msoTrue
            .Italic = msoFalse
            .Underline = msoFalse
        End With
    End With
End With

---

嗨，约翰，谢谢你，这是一个很好的开始。在第一次尝试时，我遇到一个运行时错误“要选择一个形状，它的视图必须处于活动状态”，但当我忽略它时，在第二次单击时，它就工作了。可能是因为x和y的尺寸没有定义？但我认为这段代码并不能解决我在自己的尝试中遇到的问题：在得到第一条评论后，我再也找不到了。当第一条注释在p3上，并且我想移动到p3之后的下一条注释时，此代码总是重复查找第一条注释。似乎我们需要找到一些东西让宏记住它在哪里。听起来很难-/因为我没有你的源文件，所以无法测试。我不是在为您编写宏，而是在演示如何编写所需的宏。“视图必须处于活动状态”消息表示注释不在当前幻灯片上。这就是为什么第二个循环有ActivePresentation.Slides（x）。选择此选项，则幻灯片首先处于视图中。实际上，您需要两个不同的功能：查找下一条注释，然后在下一条注释后查找注释。也许您已经注意到“查找”对话框有两个按钮：查找和查找下一个。他们是两个不同的行动。我建议您为第二个请求开始一个新问题。但与此同时，我已经回答了你的第一个问题。如果看起来我是在让你写整个宏，我很抱歉。希望我能弄明白，如果活动幻灯片上没有任何注释，如何使宏跳转到第一条注释而不显示错误消息。谢谢。我在发布之前测试了所有代码。如果第一张幻灯片上没有评论，我的列表不会出现错误。相反，它会继续搜索后续幻灯片。这就是为什么

如果oShape.Tags.Count>0，则存在
。