파워포인트 타이머

VBA를 이용한 Powerpoint 타이머입니다.

 

게임할 때, 시험볼 때나 제한 시간을 줄 때 유용합니다.

 

지정된 시간에서 카운트 다운하다가

 

00:00:00에 멈춥니다.

 

 

 

 

 

 

제일 상단에는 현재 시간이 표시되고

맨아래의 눈금은 진행 상태바라고 볼 수 있습니다. 노란색으로 점점 채워집니다.

 

우측 상단 톱니바퀴 아이콘을 누르면 제한시간을 지정할 수 있습니다.

최대 23:59:59 까지 지정할 수 있습니다.

hh:mm:ss 형식이 맞지 않으면 동작하지 않습니다.

 

카운트 도중 타이머숫자나 왼쪽 상단 아이콘을 누르면

일시정지/재시작합니다.

 

 

 

TV나 빔프로젝터 환경에 따라 16:9와 4:3 버전으로 나눴습니다.

 

16:9화면 버전

ClockTimerDown169.pptm

다운로드

 

 

4:3화면 버전

ClockTimerDown43.pptm

다운로드

 

 

 

*****

 

00:00:00가 되면 다시 카운트를 증가시키는 버전

 

16:9화면 버전

ClockTimerDown169Plus.pptm

다운로드

 

 

4:3화면 버전

ClockTimerDown43Plus.pptm

다운로드

 

16:9화면 카운트 업 버전(00:00:00부터 시작)

ClockTimerUp169.pptm

0.07MB

 

반드시 여실 때 제한된 보기 해제하고 매크로 허용하셔야 작동합니다.

기본 제한 시간은 1:00인데 이것은 소스를 고치면 됩니다.

 

*****

 

자정까지 카운트다운하는 버전을 추가합니다.

 

16:9화면 자정카운트 버전

ClockTimerDown169Plus24hour.pptm

다운로드

 

 

위 버전에서 시계를 디지털로 바꾼 버전입니다.

폰트를 사용하지 않고 도형으로 변환시킨 것이라 따로 디지털 폰트가 필요하지 않습니다.

ClockTimerDown169Plus24hDigit.pptm

다운로드

 

 

단순 디지털 시계

DigitClock1.pptm

다운로드

 

/******************* 2007~2016 32비트 및 64비트버전에서 테스트됨 ********************/

 

 

 

 

 

 

동작화면 캡쳐영상입니다.

 

 

혹시 직접 만들어보거나 수정해보고 싶어서

단순한 버전을 원하시면 아래 지식인 글을 참고하세요.

https://kin.naver.com/qna/detail.nhn?d1id=2&dirId=20602&docId=340644543&clubid=16854404&menuid=248&dirId=102020103#answer1

ClockTimerSample.pptm

다운로드

실시간 시계만 있는 샘플용 초간단 시계

ClockSample1.pptm

0.03MB

 

 

여러 페이지(4페이지)에 타이머를 추가하는 버전을 추가합니다.

관련 링크: https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=405849814 

ClockTimer_여러슬라이드예제.pptm

0.13MB

 

 

하나 더, 예전에 카페에공개한 '리얼한 시계'버전 링크합니다.

https://cafe.naver.com/gameppt/125756

 

 

 

 

Option Explicit
 
#If VBA7 Then Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _ ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Public TimerID As LongPtr '다른 타이머와 구별하기 위한 타이머의 고유ID(번호) #Else Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Public TimerID As Long '다른 타이머와 구별하기 위한 타이머의 고유ID(번호) #End If
 
 
Private HostObj As HostClass                'HostClass로 HostObj변수 선언- HostClass는 파워포인트 슬라이드쇼의 종료를 감지
'Public TimerID As Long                      '다른 타이머와 구별하기 위한 타이머의 고유ID(번호)
Public TimerCount As Date                   '타이머가 호출된 카운트
Public Pause As Boolean                     '타이머 일시정지용
Public TotalCount As Long
Const DefaultCount As String = "1:01"           '기본 타이머 시간(초) 600 -> 600/ 60 = 10분
 
Public Sub StartNext()
    
    'Start Timer
     
    'Move to the 1st Slide
    ActivePresentation.SlideShowWindow.View.Next
 
End Sub
 
Public Sub myTimer()
'1초마다 실행되는 함수로 절대 에러가 나서는 안됨.
'스스로를 호출하는 경우 에러 발생 가능성 높음.
    
    ActivePresentation.Slides(1). _
        Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
    If Pause Then Exit Sub
    If TimerCount > 0 Then TimerCount = TimerCount - 1 '타이머 1초 감소
    With ActivePresentation.Slides(1).Shapes("Timer").TextFrame2.TextRange
        .Text = Format(TimerCount / 86400, "hh:nn:ss")
        If TimerCount = 0 Then .Font.Fill.GradientStops(2).Color.RGB = rgbOrange _
            Else .Font.Fill.GradientStops(2).Color.RGB = rgbWhite
    End With
    FillRuler CInt((TotalCount - TimerCount) * 100 / TotalCount), rgbOrange
End Sub
 
Function getSeconds(s As String) As Long
    Dim spl() As String
    Dim t As Date
On Error GoTo Oops
    s = Trim(s)
    spl = Split(s, ":")
    If UBound(spl) = 0 Then
        s = "0:0:" & s
    ElseIf UBound(spl) = 1 Then
        s = "0:" & s
    ElseIf UBound(spl) > 2 Then
        GoTo Oops
    End If
    getSeconds = Hour(s) * 3600 + Minute(s) * 60 + Second(s)
    Exit Function
Oops:
    getSeconds = -1
End Function
 
Sub ResetTimer()
    Dim usr As String
    Pause = True
    usr = InputBox("타이머 설정시간을 hh:mm:ss 스타일로 입력하세요." & vbNewLine & _
        "예: 60 ->60초, 1:60 -> 1분60초, 10:10:10 -> 10시간10분10초", "타이머설정", DefaultCount)
    If Len(usr) = 0 Then Exit Sub
    usr = getSeconds(usr)
    If usr = -1 Then MsgBox "hh:mm:ss 형식이 틀립니다." & vbCr & "(23:59:59까지 지원합니다.)": Exit Sub
    
    StopTimer
    TimerCount = CLng(usr) + 1
    Pause = False
    StartTimer
End Sub
'타이머를 시작 - 슬라이드 쇼 종료전 반드시 StopTimer(KillTimer) 해줘야 함.
Public Sub StartTimer()
    If TimerCount = 0 Then TimerCount = getSeconds(DefaultCount)
    TotalCount = TimerCount
    If TimerID = 0& Then                                    ' 타이머 ID가 비어 있으면 타이머 시작
        TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer)  ' 세번째 인수가 인터벌 간격(1000 = 1초)
        Set HostObj = New HostClass                         ' 슬라이드 쇼 종료를 감지하기 시작
    End If
End Sub
 
'타이머를 종료
Public Sub StopTimer()
    Dim i As Integer
    On Error Resume Next
    KillTimer 0&, TimerID       ' 타이머 서비스를 종료
    TimerID = 0&                ' 타이머ID도 초기화
    Set HostObj = Nothing       ' HostClass 도 풀어줌; 파포종료를 감시하지 않음
    FillRuler 100, rgbWhite
End Sub
 
'타이머를 잠시 중단
Public Sub PauseTimer()
    If Pause = False Then Pause = True Else Pause = False
End Sub
 
Private Sub Delay(Seconds As Single)
    Dim TimeNow As Long
    TimeNow = Timer
    Do While Timer < TimeNow + Seconds
        DoEvents
    Loop
End Sub
 
Public Sub myExit()
    StopTimer
    ActivePresentation.SlideShowWindow.View.Exit
    'ActivePresentation.Application.Quit
End Sub
 
'슬라이드가 시작하면 자동으로 타이머 시작
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    If ActivePresentation.SlideShowWindow.View.CurrentShowPosition = 1 Then
        StartTimer
    Else
        StopTimer
    End If
End Sub
 
Sub FillRuler(oCount, oColor As Long)
    Dim i As Integer
    For i = 1 To oCount
        ActivePresentation.Slides(1).Shapes("Bar_" & i).Fill.ForeColor.RGB = oColor
    Next i
End Sub
 
Sub DrawRuler()
    Dim SW As Single, SH As Single, w As Single
    Dim shp As Shape
    Dim i As Integer
    With ActivePresentation.PageSetup
        SH = .SlideHeight: SW = .SlideWidth
        w = SW / 100
    End With
    With ActivePresentation.Slides(1).Shapes
        For i = 1 To 100
            Set shp = .AddShape(msoShapeRectangle, w * i, SH - 10, 4, 10)
            shp.Name = "Bar_" & i
            shp.Line.Visible = msoFalse
            shp.Fill.ForeColor.RGB = rgbDarkGray
            If i Mod 2 = 0 Then shp.Top = SH - 5: shp.Height = 5: shp.Width = 4: shp.Fill.Transparency = 0.5
            shp.Select msoFalse
        Next i
        ActiveWindow.Selection.ShapeRange.Group.Name = "Bar"
    End With
End Sub
 

 

 

피드백 환영합니다.

 

*** 2019.10.29.현재 64비트 호환문제로 API선언부를 모두 수정하였습니다.