найти следующую фигуру с помощью специального тега

Question

Для внутренней коммуникации в группе людей я создал макрос, добавляющий поля комментариев к слайду, а не самого 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

Работает хорошо.

У меня есть пометил их, потому что я хочу, чтобы было легко удалить их все сразу, например, в случае, если вы найдете комментарии за 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

тоже отлично работает.

Третий шаг, который я хотел бы сделать, - это создание третьего макроса, который называется «найти следующий комментарий». При каждом щелчке он переходит к следующей фигуре, помеченной тегом «КОММЕНТАРИЙ», независимо от того, находится ли эта фигура на том же слайде или на следующей или где-то еще в презентации. Просто следующий, где бы он ни был. И теперь я полностью потерялся. Я могу сделать что-то для всех помеченных фигур на одном слайде или во всей презентации - как вы можете видеть в функции для удаления. Но то, что я ищу, это не выбор всех форм одновременно. В другой попытке я смог найти первую, но после повторного нажатия на макрос ничего не происходило, потому что макрос начал искать в одной и той же точке и снова и снова выбирал одну и ту же фигуру, никогда не переходя к следующей, кроме удалил первый.

Было бы здорово прочитать ваши идеи. Заранее спасибо. Но будьте осторожны, я далеко не хороший программист. ; -)

Answer 1

Начинается с текущего слайда и работает до конца, выпадая из 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