영화엔딩크레딧 효과

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=1020201&docId=289781472&ref=me2lnk

이 질문 글에서 내용이 긴 경우 중간에 멈춘다는 분이 있어서

VBA로 텍스트를 불러와서 

글자가 위로 올라가는 애니메이션을 추가해주는 매크로를 만들었습니다.

이런 화면에서 Add 를 눌러서 텍스트파일을 선택하면

스크롤 효과를 추가하는 방식입니다.

기존 효과는 자동으로 없애기 때문에 Remove는 따로 누를 필요 없습니다.

기존에 있던 애니메이션 효과 도형을 수동으로 없애는 기능입니다.

Option : Automatic/ Manual Advance 는 

자동으로 혹은 수동으로 스크롤하는 옵션입니다.

슬라이드 화면입니다.

세가지 버전을 만들었습니다.

FadingSentences_EndingCredit1Effect        :그냥 단순하게 스크롤만 합니다.

FadingSentences_EndingCreditFade           : 약간의 페이드인 페이드 아웃을 추가했습니다.

FadingSentences_EndingCreditPause         : 애니메이션 효과가 약간 다르고 중간에 한번 살짝 멈춥니다.

FadingSentence102.pptm                       : 물결효과가 있고 다음문장으로 넘어가려면 키보드를 눌러야 합니다.

첨부파일 속의 Text 파일로 테스트 해보세요.

애니메이션 효과 자체는 파워포인트 자체 기능이므로 

만들어진 3번 슬라이드를 다른 슬라이드에 복사해도 똑같이 동작합니다.

아래는 Fade 버전의 소스입니다.

Option Base 1
 
Sub AddSentences()
    Dim shp As Shape
    Dim str() As String
    Dim i As Long, j As Long
    Dim FD As FileDialog
    Dim txtFile As String
    Dim FileNo As Integer
    Dim buffer As String
    Dim MAX As Long
    
    'First, remove sentences that were added before
    RemoveAll
    
    'Get a text file
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .Filters.Clear
        .Filters.Add "Plain text file", "*.txt"
        .InitialFileName = ActivePresentation.Path & "\"
        If .Show Then txtFile = .SelectedItems(1)
    End With
    If Len(txtFile) = 0 Then Exit Sub
    
    'Read the text file
    FileNo = FreeFile
    Open txtFile For Input As FileNo
    Do Until EOF(FileNo)
        Line Input #FileNo, buffer
        buffer = RTrim(buffer)
        If Len(buffer) Then
            i = i + 1
            ReDim Preserve str(1 To i)
            str(i) = buffer
        End If
    Loop
    MAX = i
    
'    Open txtFile For Binary Lock Read As #FileNo
'    buffer = Input$(LOF(FileNo), FileNo)
'    Close #FileNo
'    str = Split(buffer, vbNewLine)
'    MAX = UBound(str)
    
    ' Initialize str() array
'    ReDim str(MAX)
'    For i = 1 To MAX
'        str(i) = "This is the sentence #" & i
'    Next i
        
    'Let's copy the textbox on Slide #2 onto Slide #3
    Set shp = ActivePresentation.Slides(2).Shapes("TextBox 1")
    shp.Copy
    For i = 1 To MAX
        With ActivePresentation.Slides(3).Shapes.Paste
            .Left = shp.Left
            .Top = shp.Top
            .TextFrame.TextRange.Text = str(i)
            .Name = "TextBox " & i
        End With
        '애니메이션 3개의 지연을 증가
        For j = 1 To 3
            ActivePresentation.Slides(3).TimeLine.MainSequence((i - 1) * 3 + j).Timing.TriggerDelayTime = _
                (i - 1) * 1 + IIf(j = 3, 4, 0)
            'Debug.Print (i - 1) * 3 + j, (i - 1) + IIf(j = 3, 4, 0)
        Next j
    Next i
    
    ActivePresentation.Slides(3).Shapes("Go Back").ZOrder msoBringToFront
    'Message
    MsgBox "Total " & i - 1 & " sentence(s) has(have) been added."
    
    'go to the Slide #3
    If Application.SlideShowWindows.Count Then SlideShowWindows(1).View.GotoSlide 3
End Sub
 
 
Sub RemoveAll()
    Dim i As Integer, cnt As Integer
    
    With ActivePresentation.Slides(3)
        'When deleting, be sure to delete shapes from the top. Otherwise, some shapes might survive
        For i = .Shapes.Count To 1 Step -1
            If Left(.Shapes(i).Name, 8) = "TextBox " Then
                .Shapes(i).Delete
                cnt = cnt + 1
            End If
        Next i
    End With
    
    If cnt > 0 Then MsgBox "Total " & cnt & " sentence(s) has(have) been removed."
End Sub
 
 
Sub ClickOption(shp As Shape)
    Dim l As Long
    shp.ZOrder msoSendBackward
    With ActivePresentation.Slides(2).TimeLine.MainSequence(1)      '1번째 애니메이션 효과가 '클릭할 때'인데 이걸 바꿔준다.
        If shp.Name = "Manual" Then
            .Timing.TriggerType = msoAnimTriggerAfterPrevious
        Else
            .Timing.TriggerType = msoAnimTriggerOnPageClick
        End If
    End With
End Sub
 
Sub test()
    With ActivePresentation.Slides(2).TimeLine.MainSequence
        MsgBox .Item(4).EffectType & .Item(4).Exit
    End With
End Sub
 

Win7 32Bit, PPT 2010 에서 제작되었습니다.

 

다운로드(Download) 파일 링크입니다.

EndingCredit.zip

******************************************

비슷한 질문:

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020103&docId=331173084&clubid=16854404&menuid=248

동작 화면:

아래는 위 캡쳐영상에 사용된 파일입니다.

엔딩크레딧1.pptm

샘플_윤동주서시.txt

* * * * * * * * * * * * * * * * *

[2019.12.03. 추가] 

아래 캡쳐 그림처럼 스크롤 애니메이션 지속시간(속도)와 지연시간을 미리 설정할 수 있는 버전 추가합니다.

- 이동 애니메이션 효과를 이용하는 버전:

FadingSentences2.pptm

- 엔딩크레딧 효과를 이용하되 텍스트파일을 8개줄씩 끊어서 여러개의 엔딩크레딧으로 만들어주는 버전: 

FadingSentences3.pptm