How to split the content placeholder line by line into a text shape powerpoint 2010 RRS feed

  • Question

  • I am new to vb and power point , trying to run a macro in power point 2010. What i am trying to achieve is, when the macros is run, it should split the contents in the content placeholder area line by line, and placing each line in a new text box shape.

    I had done some work, but not able to move forward. The macro function is below


    Sub HelloWorldMacro()
        Dim Sld As Slide
        Dim Shp As Shape
        ' Current slide
        Set Sld = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
        For Each s In Sld.Shapes
            ' Condition - not to grab contents from title area.
            If s.Name <> "Title 1" Then
                If s.HasTextFrame Then
                    With s.TextFrame
                        If .HasText Then MsgBox .TextRange.Text
                    End With
                End If
            End If
    End Sub 

    With this i been able to grab the text from content area into a msg box. But not able to split it and place it in a text shape area.

    Also done tried some shape create function, but not able to combine these.

    Sub create_shape()
        Dim Sld As Slide
        Dim Shp As Shape
        Set Sld = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
        Set Shp = Sld.Shapes.AddShape(Type:=msoShapeRectangle, _
            Left:=24, Top:=65.6, Width:=672, Height:=26.6)
            Shp.Name = "My Header"
            Shp.Line.Visible = msoFalse
            Shp.Fill.ForeColor.RGB = RGB(184, 59, 29)
    End Sub

    • Edited by jim74897 Wednesday, July 1, 2015 3:31 PM Changed title - powerpoint 2013 to 2010
    Wednesday, July 1, 2015 3:20 PM

All replies

  • The following macro loops through each place holder, checks whether the place holder is a content place holder, and then checks whether the content place holder contains text.  If so, it creates a new rectangle for each line of text, deletes the text from the content place holder, and then deletes the content place holder.  Change the starting position of the first rectangle, height, and gap, accordingly.

    Option Explicit

    Sub ReplaceContentPlaceHoldersWithRectangles()

        Dim oSlide As Slide
        Dim oPlaceHolder As Shape
        Dim oShape As Shape
        Dim aLines() As String
        Dim mySlideHeight As Single
        Dim myTopPos As Single
        Dim myHeight As Single
        Dim Gap As Single
        Dim i As Long
        On Error GoTo ErrHandler
        mySlideHeight = ActivePresentation.PageSetup.SlideHeight 'slide height
        myTopPos = 65.6 'starting position of first rectangle
        myHeight = 26.6 'height of each rectangle
        Gap = 15 'gap between rectangles
        Set oSlide = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)
        For Each oPlaceHolder In oSlide.Shapes.Placeholders
            If oPlaceHolder.PlaceholderFormat.Type = 7 Then 'check if content place holder
                aLines = Split(oPlaceHolder.TextFrame.TextRange.Text, Chr(13))
                If UBound(aLines) <> -1 Then
                    For i = 0 To UBound(aLines)
                        If myTopPos + myHeight + Gap > mySlideHeight Then
                            MsgBox "There's not enough room on the slide.", vbInformation
                            GoTo ExitTheSub
                            Set oShape = oSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=24, Top:=myTopPos, Width:=672, Height:=myHeight)
                            With oShape
                                .TextFrame.TextRange.Text = aLines(i)
                                .Line.Visible = msoFalse
                                .Fill.ForeColor.RGB = RGB(184, 59, 29)
                            End With
                            myTopPos = myTopPos + myHeight + Gap
                        End If
                    Next i
                    With oPlaceHolder
                        .TextFrame.TextRange.Text = "" 'clear data from place holder
                        .Delete 'delete place holder
                    End With
                End If
            End If
        Next oPlaceHolder
        Set oSlide = Nothing
        Set oPlaceHolder = Nothing
        Set oShape = Nothing
        Exit Sub
        MsgBox "Error " & Err.Number & ":  " & Err.Description, vbCritical, "Error"
        Resume ExitTheSub
    End Sub

    Hope this helps!

    Domenic Tamburino Microsoft MVP - Excel - "For Your Microsoft Excel Solutions"

    Monday, July 6, 2015 12:47 AM