PPT 실시간 시계 또는 타이머 추가

PPT+VBA 2019. 12. 17. 11:16

 

모든 슬라이드에 '실시간 시계'를 추가하는 VBA예제입니다.

사용제한이 없고 사용자가 시계 폰트, 도형모양, 위치 등을 마음대로 조절할 수 있습니다.

지식인링크: https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102&docId=342538585&clubid=16854404&menuid=248&dirId=102020103

 

 

첨부한 pptm파일 매크로허용해서 여시고 한번 테스트해보세요.

슬라이드쇼를 시작하면 슬라이드 페이지가 바뀔 때마다
Slide #1의 Clock 도형을 현재 슬라이드에 복사하고
Timer API를 이용해서 1초에 한번씩 시간을 갱신합니다.
슬라이드쇼를 종료하면 타이머를 종료하고 
1슬라이드외의 모든 슬라이드의 Clock 도형을 삭제합니다.

1. 첨부파일 매크로 허용해서 여시고 Alt-F11 누르고 모듈의 매크로 소스를 복사한 다음
사용자의 PPT를 여시고 Alt-F11 창에서 삽입- 모듈 하나 추가하고 복사한 소스를 붙여넣으세요.

 

​2. 첨부 슬라이드1의 Clock 이라는 이름의 도형을 사용자의 슬라이드1에 복사하거나 하나 생성하세요.
사용자가 도형모양, 폰트, 폰트크기, 도형위치 등을 마음대로 변경할 수 있습니다.
Clock 도형이 없으면 좌측 상단에 기본 회색 둥근네모모양의 Clock도형을 자동 추가합니다.
(도형 이름 변경은 Alt-F10누르고 도형이름을 더블클릭 혹은 F2키로 할 수 있습니다.)

***사용자가 실시간 시계를 추가/수정할 필요 없이 VBA가 알아서 처리하는 버전은 V2를 참고하세요.

 

​3. 추가로, OnSlideShowBegin이 잘 작동하도록 첨부한 슬라이드1에 Label1 컨트롤을 사용자의 슬라이드1에 복사하거나 개발도구 메뉴에서 Label같은 컨트롤 아무거나 하나만 추가해놓으세요.

 

​매크로 소스는 아래와 같습니다.

더보기 
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

Const ClockName As String = "Clock"         '시간 도형의 이름
Const Default As Long = 1                '시간을 출력할 슬라이드 번호
Public Pause As Boolean                     '타이머 일시정지용


Public Sub StartNow()
    
    StartTimer

End Sub

Public Sub StopNow()
    
    StopTimer

End Sub

'// 1초마다 실행되는 함수로 절대 에러가 나서는 안됨.
'// 스스로를 재귀호출해도 에러 발생 - 주의!!.
Sub myTimer()
    Dim sld As Slide
    
    On Error Resume Next
    
    If Pause Then Exit Sub
      
    Set sld = SlideShowWindows(1).View.Slide
    sld.Shapes(ClockName).TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
    
End Sub


'타이머를 시작 - 슬라이드 쇼 종료전 반드시 StopTimer(KillTimer) 해줘야 함.
Function StartTimer()
    If TimerID = 0& Then                                    ' 타이머 ID가 비어 있으면 타이머 시작
        TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer)  ' 세번째 인수가 인터벌 간격(1000 = 1초)
    End If
End Function

'타이머를 종료
Function StopTimer()
    Dim i As Integer
    On Error Resume Next
    KillTimer 0&, TimerID       ' 타이머 서비스를 종료
    TimerID = 0&                ' 타이머ID도 초기화
End Function

'타이머를 잠시 중단
Sub PauseTimer()
     Pause = Not Pause
End Sub

'쇼 종료시 자동 실행
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)

    StopTimer
    
    ' 슬라이드1이외의 시계도형 모두 삭제
    Dim sld As Slide
    Dim shp As Shape
    
    For Each sld In ActivePresentation.Slides
        If sld.SlideIndex <> Default Then
            While shpExist(sld, ClockName)
                sld.Shapes(ClockName).Delete
            Wend
        End If
    Next sld
End Sub

'슬라이드가 시작하면 자동으로 타이머 시작
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    Dim sld As Slide
    Dim shpCount As Long
    
    Set sld = SSW.View.Slide
    
    'Clock 도형이 없으면 복사
    If Not shpExist(sld, ClockName) Then
        If sld.SlideIndex = Default Then
            'MsgBox "슬라이드1에 " & ClockName & " 도형이 있어야 합니다. 임시로 추가합니다.", vbCritical
            With sld.Shapes.AddShape(msoShapeRoundedRectangle, 0, 0, 100, 30)
                .Name = ClockName
                .Fill.ForeColor.RGB = rgbGray
                .Line.Visible = msoFalse
                .TextFrame.TextRange.Font.Bold = msoTrue
            End With
        Else
            shpCount = sld.Shapes.Count
            ActivePresentation.Slides(Default).Shapes(ClockName).Copy
            sld.Shapes.Paste (1)
            While sld.Shapes.Count <= shpCount
                DoEvents    'wait for a while
            Wend
            myTimer
        End If
    End If
    
    'Pause = False
    StartTimer

End Sub

'// 해당 슬라이드에 shpName 의 도형이 있는지 검사
Function shpExist(oSld As Slide, shpName As String) As Boolean
    Dim oShp As Shape
    
    shpExist = False
    For Each oShp In oSld.Shapes
        If oShp.Name = shpName Then shpExist = True: Exit For
    Next oShp
    
End Function

 

 

샘플파일 첨부합니다. 테스트하려면 반드시 매크로 허용해주세요.

ClockAlwaysOn.pptm
0.06MB

 

 

 

 

시계 대신 타이머를 추가하는 버전입니다.

최초에 타이머를 클릭하면 00:00:00부터 타이머를 시작합니다.

24시간이 넘어가면 다시 초기화됩니다.

 

위 코드에서 약각 수정된 코드입니다.

더보기 
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

Const ClockName As String = "Clock"         '시간 도형의 이름
Const Default As Long = 1                '시간을 출력할 슬라이드 번호
Public Pause As Boolean                     '타이머 일시정지용
Public Tick As Long

Public Sub StartNow()
    
    StartTimer

End Sub

Public Sub StopNow()
    
    StopTimer

End Sub

'// 1초마다 실행되는 함수로 절대 에러가 나서는 안됨.
'// 스스로를 재귀호출해도 에러 발생 - 주의!!.
Sub myTimer()
    Dim sld As Slide
    
    On Error Resume Next
    
    If Pause Then Exit Sub
      
    Set sld = SlideShowWindows(1).View.Slide
    sld.Shapes(ClockName).TextFrame.TextRange.Text = Format(TimeSerial(0, 0, Tick), "hh:mm:ss") 'Format(Time, "hh:mm:ss")
    Tick = Tick + 1
End Sub


'타이머를 시작 - 슬라이드 쇼 종료전 반드시 StopTimer(KillTimer) 해줘야 함.
Function StartTimer()
    If TimerID = 0& Then                                    ' 타이머 ID가 비어 있으면 타이머 시작
        TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer)  ' 세번째 인수가 인터벌 간격(1000 = 1초)
        Pause = True
    End If
End Function

'타이머를 종료
Function StopTimer()
    Dim i As Integer
    On Error Resume Next
    KillTimer 0&, TimerID       ' 타이머 서비스를 종료
    TimerID = 0&                ' 타이머ID도 초기화
    Tick = 0
End Function

'타이머를 잠시 중단
Sub PauseTimer()
     Pause = Not Pause
End Sub

'쇼 종료시 자동 실행
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)

    StopTimer
    
    ' 슬라이드1이외의 시계도형 모두 삭제
    Dim sld As Slide
    Dim shp As Shape
    
    For Each sld In ActivePresentation.Slides
        If sld.SlideIndex = Default Then
            sld.Shapes(ClockName).TextFrame.TextRange = "00:00:00"
        Else
            While shpExist(sld, ClockName)
                sld.Shapes(ClockName).Delete
            Wend
        End If
    Next sld
End Sub

'슬라이드가 시작하면 자동으로 타이머 시작
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    Dim sld As Slide
    Dim shpCount As Long
    
    Set sld = SSW.View.Slide
    
    'Clock 도형이 없으면 복사
    If Not shpExist(sld, ClockName) Then
        If sld.SlideIndex = Default Then
            'MsgBox "슬라이드1에 " & ClockName & " 도형이 있어야 합니다. 임시로 추가합니다.", vbCritical
            With sld.Shapes.AddShape(msoShapeRoundedRectangle, 0, 0, 100, 30)
                .Name = ClockName
                .Fill.ForeColor.RGB = rgbGray
                .Line.Visible = msoFalse
                .TextFrame.TextRange.Font.Bold = msoTrue
            End With
        Else
            shpCount = sld.Shapes.Count
            ActivePresentation.Slides(Default).Shapes(ClockName).Copy
            sld.Shapes.Paste (1)
            While sld.Shapes.Count <= shpCount
                DoEvents    'wait for a while
            Wend
            myTimer
        End If
    End If
    
    'Pause = False
    StartTimer

End Sub

'// 해당 슬라이드에 shpName 의 도형이 있는지 검사
Function shpExist(oSld As Slide, shpName As String) As Boolean
    Dim oShp As Shape
    
    shpExist = False
    For Each oShp In oSld.Shapes
        If oShp.Name = shpName Then shpExist = True: Exit For
    Next oShp
    
End Function

 

ClockAlwaysOnTimer.pptm
0.05MB

 

저작자표시 비영리 동일조건

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

도넛모양 다이아그램 만들기  (0) 2020.03.11
여러개의 빈줄이 있는 슬라이드 자동 추가  (0) 2020.03.05
PPT 표(Table) 서식 복사/적용  (12) 2020.01.27
PPT 실시간 시계 혹은 타이머 추가 v2  (8) 2019.12.21
PPT 한글, 영문 폰트 및 기타 속성 일괄 변경하기  (19) 2019.10.29
파워포인트에서 메뉴-서브메뉴 시스템 구현  (1) 2019.09.05
여러 PPT안의 특정 단어 검색(도형 및 VBA 코드 포함 검색)  (7) 2019.07.07
각 슬라이드에 한글자씩 가득차게 분할 출력  (0) 2019.07.02

티스토리툴바