0
votes

For internal communication purposes in a group of people I have created a macro adding comment fields to a slide - not those of PPT itself.

    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

Works well.

I have tagged them, because I want it to be easy to delete all of them at once, e.g., in case you find comments 5 minutes before you have to present. Here's my way to delete them:

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

Works fine, too.

Third step I would like to do, is creating a third macro, called "find next comment". On every click it jumps to the next shape tagged with the tag "COMMENT", no matter if that shape is on the same slide or the next or somewhere else in the presentation. Just the next one, where ever it is. And now I'm completely lost. I am able to do something to all tagged shapes on one slide or inthe entire presentation - as you can see in the function to delete. But what I'm looking for is not selecting all shapes at the same time. In another try I was able to find the first one - but after clicking the macro again nothing seemed to happen, because the macro started searching at the same point and selected the same shape again and again, never jumping to the next one, except I deleted the first one.

Would be great to read your ideas. Thank you in advance. But be careful, I'm far from being a good programmer. ;-)

1

1 Answers

1
votes

This starts at the current slide and works toward the end, dropping out of the Sub as soon as the first comment is found:

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

Bonus VBA Tip: You can make your code run a little faster by using With statements:

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