시간 제한 퀴즈 게임 템플릿

PPT+VBA 2024. 1. 1. 02:10

 

10초 시간 제한이 있는 퀴즈 게임입니다.

물론 제한 시간은 변경 가능합니다.

 

 

여기서 문제는

10초 시간이 지나면 시간 초과라는 메시지가 뜨고

확인을 누르면 다음 슬라이드로 넘어가는 것을 구현해야 합니다.

 

 

 

 

각 문제 슬라이드마다 10초 애니메이션을 적용하고 전환 시간에 10초를 적용하면 됩니다만 

다음 슬라이드로 넘어가는 순간을 알아내기 어렵습니다.

 

  • - OnSlideShowPageChange 로 슬라이드 이동을 감지하다가 페이지가 바뀌었을 때 이전 슬라이드의 진행시간이 10초를 넘었다면 시간초과 메시지를 띄우는 방식이 가능합니다. 하지만 슬라이드가 넘어가고 나서 메시지가 뜨기 때문에 혼동을 줄 수 있습니다.물론 문제 사이마다 빈 슬라이드를 넣을 수도 있으나 너무 거추장스럽습니다.

 

  • - 슬라이드쇼 시작부터 VBA Timer로 약 0.25초 간격으로 시간을 체크할 수 있겠으나 이 경우 안정적이지 못하고 DoEvents 를 해주어도 쇼 진행이 버벅이고 제대로 컨트롤 할 수 없습니다.

 

  • - 각 문제 슬라이드마다 시간초과 메시지가 있는 슬라이드를 삽입하는 방법도 있겠습니다. 시간이 초과되면 바로 다음 시간초과 슬라이드로 이동하고 문제 정답을 맞추거나 오답을 선택하면 시간초과 슬라이드를 건너뛰고 다음 문제 슬라이드로 넘어가게 하는 것입니다. 이 방법이 가장 무난한 처리 방법이 되겠습니다.

 

 

 여기서는 다른 방법으로 중간 시간초과 슬라이드 필요 없이 외부 TIMER API를 활용하는 방법을 이용하겠습니다.

 

문제 슬라이드가 시작되면 타이머를 1초마다 작동시키고 10초가 지나면 시간 초과 메시지를 띄웁니다.

슬라이드가 바뀌면 타이머는 다시 초기화 되어 타이머카운트를 다시 시작합니다.

화면 하단에 남은 시간을 알리는 타이머 바가 애니메이션됩니다.

타이머 바를 클릭하면 타이머를 잠시 중단하고 다시 누르면 다시 시작합니다.

 

 

아래 타이머 바는 100개의 네모를 만들어서 이용합니다. 

2슬라이드부터 6슬라이드까지 약간씩 다른 모양이나 애니메이션을 이용합니다.

 

오른쪽에서 왼쪽으로 이동하기도 하고

3슬라이드는 슬라이드 레이아웃의 애니메이션을 이용하기도 하고

10개씩 묶어서 총 10번의 애니메이션을 재생하기도 합니다.

 

100개의 애니메이션을 간혹 슬라이드쇼 재생을 버벅이게 만들기 때문에 2슬라이드처럼 10개씩 묶어서 복사해서 그림으로 다시 붙여넣은 다음 애니메이션을 적용시키는 것이 좋습니다.

 

정답/오답 판정은 도형의 이름 뒤에 Answer1_5나 Answer3_10 처럼 언더바(_) 다음에 점수를 적어주면 정답, 없으면 오답으로 처리합니다. 틀렸을 때 감점을 할 때도 이 _5 와 같은 점수를 찾아 감점하게 됩니다.

 

 

문제 슬라이드의 배경은 슬라이드 마스터 레이아웃 몇가지를 제공합니다.

 

 

맨 마지막 슬라이드에서 퀴즈 결과를 표시합니다.

맞은 개수, 틀린 개수, 총점을 표시합니다.

 

Retry를 누르면 다시 처음부터 문제를 풉니다.

 

실행 영상:

 

 

 

샘플파일:

 

- Timer API를 이용한 버전 : 

Quiz1_A.pptm
2.71MB

 

- 코드 보기:

더보기 
Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Public TimerID As LongPtr
#Else
    Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Public TimerID As Long
#End If
    
'타이머 카운트
Dim TimerCount As Long              '타이머 누적
Dim TimeOver As Boolean             '시간 초과 여부 표시
Dim TimerPaused As Boolean          '타이머 일시 정지

Const TimeLimit As Long = 10        '슬라이드당 제한시간
Const DebugMode As Boolean = False  '디버그 출력 여부
 
'정답 클릭
Sub ClickAnswer(shp As Shape)
    
    Dim pt As Integer
    
    If shp.Name Like "Answer?_*" Then
        pt = Int(Split(shp.Name, "_")(1))
        If DebugMode Then Debug.Print shp.Parent.SlideIndex, "정답", shp.Name, pt
        TimeOver = True
        MsgBox "정답!", vbInformation
    Else
        pt = -getPoint(shp.Parent)
        If DebugMode Then Debug.Print shp.Parent.SlideIndex, "오답", shp.Name, pt
        TimeOver = True
        MsgBox "오답!", vbCritical
    End If
        
    UpdatePoint pt
    SlideShowWindows(1).View.GotoSlide shp.Parent.SlideIndex + 1, msoTrue
    
End Sub

'점수 찾기
Function getPoint(oSld As Slide) As Integer
  
    Dim oShp As Shape
    Dim p As Integer
    
    For Each oShp In oSld.Shapes
        If oShp.Name Like "Answer?_*" Then
            p = Int(Split(oShp.Name, "_")(1))
        End If
    Next oShp
    getPoint = p
    
End Function

Private Sub UpdatePoint(p As Integer)

    Dim sld As Slide
    With ActivePresentation
        Set sld = .Slides(.Slides.Count)
    End With
    
    If p > 0 Then
        With sld.Shapes("nCorrect").TextFrame.TextRange
            .Text = Val(.Text) + 1
        End With
    Else
        With sld.Shapes("nWrong").TextFrame.TextRange
            .Text = Val(.Text) + 1
        End With
    End If
    With sld.Shapes("nPoints").TextFrame.TextRange
        .Text = Val(.Text) + p
    End With

End Sub

'Initialize points
Private Sub InitPoints()

    Dim sld As Slide
    With ActivePresentation
        'For Each sld In .Slides
        '    If sld.SlideIndex > 1 And sld.SlideIndex < .Slides.Count Then _
        '        sld.Shapes("TimerCount").TextFrame.TextRange = ""
        'Next sld
        Set sld = .Slides(.Slides.Count)
    End With
    
    sld.Shapes("nCorrect").TextFrame.TextRange.Text = "0"
    sld.Shapes("nWrong").TextFrame.TextRange.Text = "0"
    sld.Shapes("nPoints").TextFrame.TextRange.Text = "0"

End Sub

'timer : any error not allowed
Private Sub myTimer()
    Dim sld As Slide
    Dim pt As Integer
    
    On Error Resume Next
    
    If TimerPaused Then Exit Sub
    
    TimerCount = TimerCount + 1
    
    Set sld = SlideShowWindows(1).View.Slide
    If TimerCount <= TimeLimit Then
        'sld.Shapes("TimerCount").TextFrame.TextRange = TimerCount
    Else
        If Not TimeOver Then
            TimeOver = True
            MsgBox "시간 초과!", vbCritical
            pt = -getPoint(sld)
            UpdatePoint pt
            If DebugMode Then Debug.Print sld.SlideIndex, "시간초과", pt
            SlideShowWindows(1).View.GotoSlide sld.SlideIndex + 1, msoTrue
        End If
    End If

End Sub

Private Sub startTimer()
    TimerPaused = False
    If TimerID = 0& Then
        TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer)  ' 1000 = 1초, 500 = 0.5초
    End If
End Sub

Private Sub stopTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
    TimerID = 0&
    TimerCount = 0
End Sub

Sub PauseTimer()
    TimerPaused = Not TimerPaused
    If TimerPaused Then
         SlideShowWindows(1).View.State = ppSlideShowPaused
    Else
        SlideShowWindows(1).View.State = ppSlideShowRunning
    End If
End Sub

Sub onSlideShowTerminate(SSW As SlideShowWindow)
    
    stopTimer
   
End Sub

Sub StartQuiz(shp As Shape)
    InitPoints
    SlideShowWindows(1).View.GotoSlide shp.Parent.SlideIndex + 1, msoTrue
End Sub

'페이지가 변할 때마다 호출
Sub onSlideShowPageChange(SSW As SlideShowWindow)

    TimeOver = False
    TimerPaused = False
    stopTimer
    With SSW.View.Slide
        If .SlideIndex = 1 Then
            'InitPoints
        ElseIf .SlideIndex > 1 And .SlideIndex < SSW.Presentation.Slides.Count Then
            startTimer
        End If
        
    End With
    
End Sub

'첫번째 Adjustment를 나머지 도형에 똑같이 적용
Private Sub AdjustAll()

    Dim shp As Shape
    Dim i%, j%

    With ActiveWindow.Selection
        For Each shp In .ShapeRange
            i = i + 1
            If i > 1 Then
                For j = 1 To shp.Adjustments.Count
                    shp.Adjustments(j) = .ShapeRange(1).Adjustments(j)
                Next j
            End If
        Next shp
    End With

End Sub

'선택된 도형에 색상 채우기
Private Sub FillColor()

    Dim sr As ShapeRange
    Dim i%
    
    Set sr = ActiveWindow.Selection.ShapeRange
    For i = 1 To sr.Count
        sr(i).Fill.ForeColor.RGB = RGB(200 + Int((i - 1) / 10) * 5, 200 - Int((i - 1) / 10) * 10, 50)
    Next i
    
End Sub

'선택된 그룹 도형 내부의 모든 도형에 특정 매크로 지정
Private Sub ApplyAction()
    Dim shp As Shape, cshp As Shape
 
    For Each shp In ActiveWindow.Selection.ShapeRange
        ApplyActionFunc shp
    Next shp
End Sub

Function ApplyActionFunc(oShp As Shape)
    Dim cshp As Shape
    If oShp.Type = msoGroup Then
        For Each cshp In oShp.GroupItems
            ApplyActionFunc cshp
        Next cshp
    Else
        With oShp.ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "PauseTimer"
        End With
    End If
End Function

Private Sub ChangeDotStyle()
    Dim shp As Shape
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    shp.Line.DashStyle = msoLineSysDot
End Sub

 

 

- VBA코드를 줄이고 문제 사이에 빈슬라이드를 이용한 버전:

 

Quiz1_B.pptm
2.72MB

 

 

- 코드 보기

더보기 
Option Explicit
  
Const DebugMode As Boolean = False  '디버그 출력 여부
 
'정답 클릭
Sub ClickAnswer(shp As Shape)
    
    Dim pt As Integer
    
    If shp.Name Like "Answer?_*" Then
        pt = Int(Split(shp.Name, "_")(1))
        If DebugMode Then Debug.Print shp.Parent.SlideIndex, "정답", shp.Name, pt
        MsgBox "정답!", vbInformation
    Else
        pt = -getPoint(shp.Parent)
        If DebugMode Then Debug.Print shp.Parent.SlideIndex, "오답", shp.Name, pt
        MsgBox "오답!", vbCritical
    End If
        
    UpdatePoint pt
    '시간초과 슬라이드 건너뛰기
    SlideShowWindows(1).View.GotoSlide shp.Parent.SlideIndex + 2, msoTrue
    
End Sub

'점수 찾기
Function getPoint(oSld As Slide) As Integer
  
    Dim oShp As Shape
    Dim p As Integer
    
    For Each oShp In oSld.Shapes
        If oShp.Name Like "Answer?_*" Then
            p = Int(Split(oShp.Name, "_")(1))
        End If
    Next oShp
    getPoint = p
    
End Function

Private Sub UpdatePoint(p As Integer)

    Dim sld As Slide
    With ActivePresentation
        Set sld = .Slides(.Slides.Count)
    End With
    
    If p > 0 Then
        With sld.Shapes("nCorrect").TextFrame.TextRange
            .Text = Val(.Text) + 1
        End With
    Else
        With sld.Shapes("nWrong").TextFrame.TextRange
            .Text = Val(.Text) + 1
        End With
    End If
    With sld.Shapes("nPoints").TextFrame.TextRange
        .Text = Val(.Text) + p
    End With

End Sub

'Initialize points
Private Sub InitPoints()

    Dim sld As Slide
    With ActivePresentation
        'For Each sld In .Slides
        '    If sld.SlideIndex > 1 And sld.SlideIndex < .Slides.Count Then _
        '        sld.Shapes("TimerCount").TextFrame.TextRange = ""
        'Next sld
        Set sld = .Slides(.Slides.Count)
    End With
    
    sld.Shapes("nCorrect").TextFrame.TextRange.Text = "0"
    sld.Shapes("nWrong").TextFrame.TextRange.Text = "0"
    sld.Shapes("nPoints").TextFrame.TextRange.Text = "0"

End Sub
 
Sub onSlideShowTerminate(SSW As SlideShowWindow)
    
    DoEvents
End Sub

Sub StartQuiz(shp As Shape)
    InitPoints
    SlideShowWindows(1).View.GotoSlide shp.Parent.SlideIndex + 1, msoTrue
End Sub

'페이지가 변할 때마다 호출
Sub onSlideShowPageChange(SSW As SlideShowWindow)
    Dim sld As Slide
    Dim pt As Integer
    
    Set sld = SSW.View.Slide
    If sld.SlideIndex > 1 And sld.SlideIndex < SSW.Presentation.Slides.Count Then
        If sld.SlideIndex Mod 2 = 1 Then
            MsgBox "시간 초과!", vbCritical
            pt = getPoint(SSW.Presentation.Slides(sld.SlideIndex - 1))
            UpdatePoint -pt
            If DebugMode Then Debug.Print sld.SlideIndex, "시간초과", pt
            SSW.View.GotoSlide sld.SlideIndex + 1, msoTrue
        End If
    End If
    
End Sub

'첫번째 Adjustment를 나머지 도형에 똑같이 적용
Private Sub AdjustAll()

    Dim shp As Shape
    Dim i%, j%

    With ActiveWindow.Selection
        For Each shp In .ShapeRange
            i = i + 1
            If i > 1 Then
                For j = 1 To shp.Adjustments.Count
                    shp.Adjustments(j) = .ShapeRange(1).Adjustments(j)
                Next j
            End If
        Next shp
    End With

End Sub

'선택된 도형에 색상 채우기
Private Sub FillColor()

    Dim sr As ShapeRange
    Dim i%
    
    Set sr = ActiveWindow.Selection.ShapeRange
    For i = 1 To sr.Count
        sr(i).Fill.ForeColor.RGB = RGB(200 + Int((i - 1) / 10) * 5, 200 - Int((i - 1) / 10) * 10, 50)
    Next i
    
End Sub

'선택된 그룹 도형 내부의 모든 도형에 특정 매크로 지정
Private Sub ApplyAction()
    Dim shp As Shape, cshp As Shape
 
    For Each shp In ActiveWindow.Selection.ShapeRange
        ApplyActionFunc shp
    Next shp
End Sub

Function ApplyActionFunc(oShp As Shape)
    Dim cshp As Shape
    If oShp.Type = msoGroup Then
        For Each cshp In oShp.GroupItems
            ApplyActionFunc cshp
        Next cshp
    Else
        With oShp.ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "PauseTimer"
        End With
    End If
End Function

Private Sub ChangeDotStyle()
    Dim shp As Shape
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    shp.Line.DashStyle = msoLineSysDot
End Sub
저작자표시 비영리 동일조건

'PPT+VBA' 카테고리의 다른 글

편집 모드에서 자동으로 동영상 재생  (0) 2024.03.13
Freeform 도형을 따라 잉크 그리기 애니메이션 자동 생성  (1) 2024.02.25
100슬라이드 중 랜덤(무작위) 5슬라이드 재생  (1) 2024.01.19
테이블(표) 윤곽선 따라 가이드 선 자동 추가  (1) 2024.01.15
폴더 내의 모든 PPT를 PDF로 일괄로 내보내기  (0) 2023.12.17
폴더 내의 모든 PPT파일을 동영상으로 내보내기  (0) 2023.12.04
특정 슬라이드쇼 설정으로 항상 쇼를 시작  (0) 2023.11.18
장바구니 결제 화면 구현  (0) 2023.11.05

티스토리툴바