Access/VBA Library

PopulateTextShape

Gets the current shape and duplicates it for every element in the Content parameter and adds animations to show one shape at a time. Animations are trigger by mouse-click as default but also a timer can be set.

This function is usefull for creating a slide containing more text than a shape can hold or to create a countdown timer.

Syntax

PopulateTextShape( Content [, SetTimer] [, TimerDelayTime] )
Parameters
Name Type Description
Content Variant Required. An Array containing the text to populate.
SetTimer Boolean Optional. Indicates if shapes should be animated on timer (when True) or mouse-click (when False).
Default: False
TimerDelayTime Long Optional. The delaytime for the animations when SetTimer is set to True.
Default: 1
Code
Public Sub PopulateTextShape(Content, _
                               Optional ByVal SetTimer As Boolean = False, _
                               Optional ByVal TimerDelayTime As Long = 1)

    Dim Index As Long
    Dim CurrentShape As Shape
    Dim NewShape As Shape
    Dim PrevShape As Shape
    Dim DummyShape As Shape
    '
    ' Check if there is an active shape and text is passed
    '
    If ActiveShape Is Nothing Then Exit Sub
    If Not IsArray(Content) Then Exit Sub
    If UBound(Content) = -1 Then Exit Sub
    '
    ' Initialisations
    '
    Set CurrentShape = ActiveShape
    Set PrevShape = ActiveShape
    Set DummyShape = CurrentShape.Duplicate(1)
    '
    ' Fill currentshape with first content
    '
    Index = LBound(Content)
    CurrentShape.TextFrame.TextRange.Text = Content(Index)
    
    For Index = LBound(Content) + 1 To UBound(Content)
        '
        ' Create a new shape based on the current one
        '
        Set NewShape = DummyShape.Duplicate(1)
        With NewShape
            .name = CurrentShape.name & "_" & Index
            .TextFrame.TextRange.Text = Content(Index)
            .Top = CurrentShape.Top
            .Left = CurrentShape.Left
        End With
        '
        ' Add animations
        '
        With ActiveSlide.TimeLine.MainSequence
            If SetTimer Then
                '
                ' Add timer of 1 second
                '
                With .AddEffect(NewShape, msoAnimEffectAppear, , msoAnimTriggerAfterPrevious)
                    .Timing.TriggerDelayTime = TimerDelayTime
                End With
            Else
                '
                ' No timer then animate on mouse-click
                '
                .AddEffect NewShape, msoAnimEffectAppear, , msoAnimTriggerOnPageClick
            End If
            '
            ' When NewShape will appear, then the previous one must be hidden by an exit effect
            '
            With .AddEffect(PrevShape, msoAnimEffectAppear, , msoAnimTriggerAfterPrevious)
                If SetTimer Then .Timing.TriggerDelayTime = 0
                .Exit = msoCTrue
            End With
        End With
        '
        ' Save reference to new shape to add Exit effect to
        '
        Set PrevShape = NewShape
    Next Index
    
    DummyShape.Delete
End Sub

PowerPointtag:PowerPoint

Remarks

  • There should be one shape active when executing this function.

See also

  • PopulateTextShape_Example