애니메이션 점수판 자동 생성

 

 

 

VBA를 이용해서 위와 같은 애니메이션 점수판을 자동 생성합니다.

 

작동화면입니다. 애니메이션 창을 켜놓아서 영상 뒷부분은 버벅입니다.

 

 

점수판을 생성하고 싶다면 첨부파일을 차단해제하고 매크로 허용해서 열고

새 슬라이드에서 

Alt+F8 로 Auto 매크로를 실행합니다.

 

그러면 팀의 개수와 최고 점수를 묻는데 5, 10 을 입력하면 5팀 10점짜리 점수판이 생성됩니다.

2,15 라든가 4, 5 혹은 10, 5 등 원하는대로 팀의 개수와 최고 점수를 입력할 수 있습니다.

 

 

가장 큰 특징은 아래처럼 모든 기능이  VBA가 필요 없이 애니메이션으로 구동한다는 점입니다.

애니메이션으로 직접 만드는 방법은 지식인 링크를 참고하세요.

투명도형과 약간 복잡한 트리거 애니메이션을 이용하였습니다.

최종 결과물은 매크로를 제외하고 pptx로 저장해도 완벽하게 작동합니다.

 

 

활용 방법은 슬라이드쇼에서 맨 아래의 조 이름을 클릭하면 해당 조의 점수가 올라가고

각 조의 제일 상단 점수를 누르면 점수가 1점씩 취소됩니다. 간단한 사운드 효과도 추가했습니다.

 

오디오 파일 2개는 슬라이드마스터 레이아웃1에 저장되어 있고 점수판을 생성할 때마다 복사해와서 재생 애니메이션을 적용해줍니다.

 

슬라이드 외곽의 여백과 각각의 점수 도형의 여백은 VBA코드의 숫자를 수정하세요.

mww 는 점수판 테두리의 슬라이드 가로 여백, mhh 는 세로 여백입니다.

mw와 mh는 점수 도형 둘레의 가로, 세로 여백입니다.

    '팀명은 팀개수+1개 생성
    mww = 100: mhh = 30                         '가장 외곽 여백

    mw = 2:  mh = 2    'mw = 20:  mh = 6        '점수도형 여백

 

 

생성 후에 슬라이드 배경을 변경하거나 점수 도형을 편집하거나 색상을 변경할 수 있습니다.

레이아웃에 몇가지 배경이 들어 있습니다.

 

점수도형만 선택하고 싶다면

코드창에서 mySelect 함수를 F5로 실행한 다음 "P_*" 을 입력하면 점수 도형만 선택 가능합니다.

 

조별로 자동으로 색상을 변경할 수도 있습니다.

코드창에서 ChangeColor 함수에 커서를 두고 F5로 실행하면 됩니다.

 

 

이제 위와 같은 기능으로 자동으로 생성한 후 약간씩 편집한 여러가지 점수판 예시입니다.

 

기본 색상의 점수판:

 

6팀 15점짜리

 

6팀 10점짜리

 

8팀 8점짜리

 

6팀 10점짜리  - 입체도형 이용

 

5팀 10점짜리 - 3D효과 적용

 

 

슬라이드쇼 설정을 '웹형식으로 진행'으로 바꾸고

슬라이드쇼 창을 작게 해놓고 팀별로 점수를 부여하면서

다른 발표를 진행해도 되겠습니다.

 

VBA 코드:

Option Explicit

Sub Auto()

    Dim sld As Slide
    Dim shp As Shape, tshp As Shape, ashp As Shape, ushp As Shape
    Dim usr As String, teamCount%, teamMaxPoint%
    Dim SW!, SH!, ww!, hh!, w!, h!, x!, y!, mw!, mh!, mww!, mhh!
    Dim t%, c%, i%
    Dim eft As Effect
    
    usr = InputBox("조별 점수판을 생성합니다. 팀의 개수와 최고점을 입력하세요:", "애니메이션 점수판 생성", "5, 10")
    If Not usr Like "*,*" Then MsgBox "콤마로 구분한 숫자 2개를 입력하세요.": Exit Sub
    
    teamCount = CInt(Split(usr, ",")(0))
    teamMaxPoint = CInt(Split(usr, ",")(1))
    If teamCount < 1 Or teamMaxPoint < 1 Then Exit Sub
    
    With ActivePresentation.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
    
    Set sld = ActiveWindow.Selection.SlideRange(1)
    sld.SlideShowTransition.AdvanceOnClick = msoFalse
    
    If sld.Shapes.Count > 2 Then
        If sld.Shapes(3).Name Like "*_*" Then _
            If MsgBox("기존 도형들을 모두 지울까요?", vbYesNo) = vbYes Then removeAll
    End If
    
    InsertAudio '오디오 효과 삽입
    
    '팀명은 팀개수+1개 생성
    mww = 100: mhh = 30                         '가장 외곽 여백
    hh = (SH - mhh * 2) / (teamMaxPoint + 1)    '팀이름 도형 포함
    ww = (SW - mww * 2) / teamCount
    mw = 2:  mh = 2    'mw = 20:  mh = 6                            '점수도형 여백
    w = ww - mw * 2:  h = hh - mh * 2
    
    '팀별 점수 도형 생성
    For t = 0 To teamCount - 1
        For c = 0 To teamMaxPoint
            x = mww + t * ww + mw
            y = mhh + (teamMaxPoint - c) * hh + mh
            '팀 이름
            If c = 0 Then
                Set shp = sld.Shapes.AddShape(msoShapeRound2SameRectangle, x, y, w, h)
                shp.Line.Visible = msoTrue
                shp.Line.ForeColor.RGB = rgbOrange
                shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
                'shp.Fill.Transparency = 1
                shp.TextFrame.TextRange.Font.Color = rgbDarkOrange
                shp.TextFrame.TextRange.Text = t + 1 & " 조"
                shp.Name = "A_" & t + 1
                '팀이름 겹치는 투명 도형
                For i = teamMaxPoint To 1 Step -1
                    With shp.Duplicate(1)
                        .Line.Visible = msoFalse
                        .Fill.Transparency = 1
                        .Left = shp.Left: .Top = shp.Top
                        .TextFrame.TextRange.Delete
                        .Name = "B_" & t + 1 & "_" & i
                    End With
                Next i
            '점수
            Else
                '점수 도형 배경
                Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h)
                shp.Fill.Visible = msoFalse
                shp.Line.Weight = 0.1
                shp.Line.DashStyle = msoLineSysDash
                shp.Line.Visible = msoTrue
                shp.Line.ForeColor.RGB = rgbLightGray
                shp.TextFrame.TextRange.Text = c
                shp.TextFrame.TextRange.Font.Color.RGB = RGB(245, 245, 245)
                shp.Name = "C_" & t + 1 & "_" & c
                
                '점수 도형
                Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h)
                shp.Fill.ForeColor.RGB = RGB(156 + (100 / teamMaxPoint) * c, _
                    250 - (100 / teamMaxPoint) * c, 200 - (200 / teamMaxPoint) * c)
                shp.Line.Visible = msoFalse
                shp.TextFrame.TextRange.Text = c
                shp.Name = "P_" & t + 1 & "_" & c
                
                '점수 도형 위 클릭방지용 투명도형
                If c < teamMaxPoint Then
                    Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h)
                    shp.Fill.Transparency = 1
                    shp.Line.Visible = msoFalse
                    shp.Name = "T_" & t + 1 & "_" & c
                End If
            End If
            
        Next c
    Next t
    
    
    '//애니메이션 설정
     For t = 1 To teamCount
        For c = 1 To teamMaxPoint
            
            '//팀이름 클릭할 때 점수 도형 나타내기
            Set tshp = sld.Shapes("B_" & t & "_" & c)
            Set shp = sld.Shapes("P_" & t & "_" & c)
            
            '팀이름 투명 도형 클릭시 점수도형 나타나기
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(shp, msoAnimEffectRiseUp, _
                msoAnimTriggerOnShapeClick, tshp)
            eft.Timing.Duration = 0.25
            'tshp.ActionSettings(ppMouseClick).SoundEffect.ImportFromFile "C:\Program Files\Microsoft Office\root\chimes.wav"
            
            '딩동 소리 효과
            Set ashp = sld.Shapes("X_right")
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(ashp, msoAnimEffectMediaPlay, _
                msoAnimTriggerOnShapeClick, tshp)
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious
            
            ''바로 아래 클릭방지 투명 점수도형 나타나기
            If c > 1 Then
                Set ushp = sld.Shapes("T_" & t & "_" & c - 1)
                Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(ushp, msoAnimEffectAppear, _
                msoAnimTriggerOnShapeClick, tshp)
                eft.Timing.TriggerType = msoAnimTriggerWithPrevious
            End If
            
            '팀이름 투명 도형은 사라지기
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(tshp, msoAnimEffectAppear, _
                msoAnimTriggerOnShapeClick, tshp)
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious
            eft.Exit = msoTrue
            
            '점수 도형 누르면 스스로 사라지기
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(shp, msoAnimEffectAppear, _
                msoAnimTriggerOnShapeClick, shp)
            eft.Exit = msoTrue
            
            '딩 소리 효과
            Set ashp = sld.Shapes("X_wrong")
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(ashp, msoAnimEffectMediaPlay, _
                msoAnimTriggerOnShapeClick, shp)
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious
               
            ''바로 아래 클릭방지 투명 점수도형 사라지기
            If c > 1 Then
                Set ushp = sld.Shapes("T_" & t & "_" & c - 1)
                Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(ushp, msoAnimEffectAppear, _
                msoAnimTriggerOnShapeClick, shp)
                eft.Exit = msoTrue
                eft.Timing.TriggerType = msoAnimTriggerWithPrevious
            End If
               
            '점수 도형 누르면 팀이름은 다시 나타나기
            Set eft = sld.TimeLine.InteractiveSequences.Add().AddTriggerEffect(tshp, msoAnimEffectAppear, _
                msoAnimTriggerOnShapeClick, shp)
            eft.Timing.TriggerType = msoAnimTriggerWithPrevious
   
        Next c
    Next t
 
End Sub

Function removeAll()
    
    Dim prs As Presentation, sld As Slide, eft As Effect
    Dim i As Integer
    
    Set sld = ActiveWindow.Selection.SlideRange(1)
    '도형 삭제
    With sld.Shapes
        For i = .Count To 1 Step -1
            If .Item(i).Name Like "*_*" Then .Item(i).Delete
        Next i
    End With
    '남은 애니메이션 삭제
    With sld.TimeLine.MainSequence
        For i = .Count To 1 Step -1
            'If .Item(i).Shape.Name Like "X_*" Then
            .Item(i).Delete
        Next i
    End With
    
End Function

Function InsertAudio()
    Dim prs As Presentation, sld As Slide
    Set sld = ActiveWindow.Selection.SlideRange(1)
    
    '효과음 추가
    Set prs = sld.Parent
    With prs.Designs(1).SlideMaster.CustomLayouts(1)
        If Not shpExist(sld, "X_right") Then
            .Shapes("X_right").Copy
            sld.Shapes.Paste: DoEvents
        End If
        If Not shpExist(sld, "X_wrong") Then
            .Shapes("X_wrong").Copy
            sld.Shapes.Paste: DoEvents
        End If
    End With
    
End Function

Function shpExist(oSld, sName) As Boolean
    Dim shp As Shape
    
    For Each shp In oSld.Shapes
        If shp.Name Like sName Then shpExist = True: Exit For
    Next shp
End Function

'원하는 패턴의 이름을 가진 도형을 일괄로 선택
Private Sub mySelect()
    Dim usr As String, def As String
    Dim shp As Shape
    Dim sld As Slide
    
    On Error Resume Next
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    On Error GoTo 0
    If Not shp Is Nothing Then def = shp.Name & "*"
    
    usr = InputBox("선택할 도형 이름 패턴을 입력하세요.", "도형 선택", def)
    If usr = "" Or usr = "False" Then Exit Sub
    Set sld = ActiveWindow.Selection.SlideRange(1)
    'ActiveWindow.Selection.Unselect
    For Each shp In sld.Shapes
        If shp.Name Like usr Then shp.Select msoFalse
    Next shp
End Sub

'점수 도형의 색깔을 랜덤으로 섞기
Private Sub ChangeColor()
    Dim sld As Slide, shp As Shape
    Dim t%, c%, teamCount%, teamMaxPoint%, r&
    
    Randomize
    Set sld = ActiveWindow.View.Slide
    teamCount = 0:    teamMaxPoint = 0
    For Each shp In sld.Shapes
        If shp.Name Like "A_*" Then
            teamCount = teamCount + 1
        ElseIf shp.Name Like "P_*_*" Then
            t = Split(shp.Name, "_")(2)
            If teamMaxPoint < t Then teamMaxPoint = t
        End If
    Next shp

    For t = 1 To teamCount
        r = RGB(Int(Rnd * 200), Int(Rnd * 200), Int(Rnd * 200))
        For c = 1 To teamMaxPoint
            With sld.Shapes("P_" & t & "_" & c).Fill
                .ForeColor.RGB = r
                .Transparency = 0.4 * (1 / teamMaxPoint) * (teamMaxPoint - c)
            End With
        Next c
    Next t
    
End Sub

 

관련 : 지식인

 

파일 다운로드:

 

- 애니메이션점수판 자동 생성

팀별점수판생성2.pptm

1.29MB

 

- 생성예시 : 6팀 10점짜리 pptx

팀별점수판생성21-6_10.pptx

1.11MB