TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub WrapOver()

    Dim SldCnt As Long
    Dim SldNum As Long
    Dim WrapCnt As Long
    Dim OldCnt As Long

    SldCnt = ActivePresentation.Slides.Count
    OldCnt = SldCnt

    WrapCnt = InputBox("'Wrap' text in placeholder " & _
        "if they exceed how many lines?", "Wrap after" & _
        "input", "6")

    If WrapCnt > 15 Or WrapCnt < 2 Then
        MsgBox "Please enter a number between 2 and 15" & _
        ", when you re-run this macro", vbCritical + _
        vbOKOnly, "Input range error"
        Exit Sub
    End If

    SldNum = 0
    With ActivePresentation

NextSlide:
        SldNum = SldNum + 1
        If SldNum > SldCnt Then
            GoTo EndRoutine
        End If

        ' Ignore slides with no second placeholder shape
        On Error Resume Next
        If .Slides(SldNum).Shapes.Placeholders(2) _
            .TextFrame.TextRange.Lines _
            .Count <= WrapCnt Then
                GoTo NextSlide
        End If
        On Error GoTo ErrorHandler

        .Slides(SldNum).Duplicate
        SldCnt = SldCnt + 1
        With .Slides(SldNum).Shapes.Placeholders(2).TextFrame.TextRange
            .Lines(WrapCnt + 1, .Lines.Count).Delete
        End With
        .Slides(SldNum + 1).Shapes.Placeholders(2) _
            .TextFrame.TextRange.Lines(1, WrapCnt).Delete
        GoTo NextSlide

EndRoutine:
        End With
        MsgBox "Task complete.  " & SldCnt - OldCnt & _
            " slides were added.", vbOKOnly, WrapCnt & _
            " line max. macro"

NormalExit:
    Exit Sub
ErrorHandler:
    Resume NormalExit

End Sub