PPT 실시간 시계 혹은 타이머 추가 v2

PPT+VBA 2019. 12. 21. 23:04

 

지난 버전에 이어서

이번에는 첫슬라이드에 시계 도형을 만들 필요 없이

전부 VBA로 clock 시계도형을 추가하도록 수정해보았습니다.

 

사용자가 할 일은 아래의 VBA코드를 복사해서

사용자의 PPT 의 Alt-F11 VBE 코드창에 붙여넣는 것 뿐입니다.

 

구체적으로 말하자면 파워포인트 일반편집창에서 'Alt-F11'키 눌러서 VBE코드창 연 다음

[삽입 - 모듈] 메뉴에서 '모듈'을 하나 추가하고 아래에서 복사한 코드를 붙여넣고

F5 슬라이드쇼 테스트 한번 하면 됩니다.

 

혹시나 시계가 시작하지 않는다면 Alt-F8 누르고 'FirstRun' 함수를 딱 한번만 실행시켜주세요.

(이건 혹시 SlideShowPageChange가 간혹 실행되지 않는 것을 막기 위해

1슬라이드에 Label 컨트롤을 하나 추가해줍니다. 특히 ppsm파일의 경우 필요합니다.)

 

동작화면은 아래 캡쳐영상 참고하세요.

 

복사할 매크로 코드입니다.

더보기 
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"         '시간 도형의 이름
Public Pause As Boolean                     '타이머 일시정지용
Public Blink 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
    With sld.Shapes(ClockName).TextFrame2.TextRange
        If Not Blink Then
            .Text = Format(Time, "hh:mm:ss")
            
        Else
            .Characters(3, 1).Font.Fill.Transparency = 0.95
            .Characters(6, 1).Font.Fill.Transparency = 0.95
        End If
    End With
    Blink = Not Blink
    
End Sub


'// 타이머를 시작 - 슬라이드 쇼 종료전 반드시 StopTimer(KillTimer) 해줘야 함.
Function StartTimer()
    If TimerID = 0& Then                                    ' 타이머 ID가 비어 있으면 타이머 시작
        TimerID = SetTimer(0&, 0&, 500&, 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
    
    RemoveAllClocks
    
End Sub

'// 슬라이드가 시작하면 자동으로 타이머 시작
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    Dim sld As Slide
    
    Set sld = SSW.View.Slide
    
    '라벨 없으면 하나 추가
    If sld.SlideIndex = 1 Then FirstRun
    'Clock 도형이 없으면 생성
    If Not shpExist(sld, ClockName) Then AddClock
    myTimer
    
    'Pause = False
    StartTimer

End Sub

'// 현재 슬라이드에 시계 도형을 추가
Function AddClock()
    Dim sld As Slide
    Dim shp As Shape
    Dim SW As Single
    
    Set sld = ActivePresentation.SlideShowWindow.View.Slide
    If shpExist(sld, ClockName) Then Exit Function
    SW = ActivePresentation.PageSetup.SlideWidth
    With sld.Shapes.AddShape(msoShapeRoundedRectangle, SW - 100, 0, 100, 30)
        .Name = ClockName
        .Adjustments(1) = 0.1                           '둥근 곡률
        .Fill.ForeColor.RGB = rgbLightGray              '배경색
        .Fill.Transparency = 0.8                        '투명도
        .Line.Visible = msoFalse                        '윤곽선
        .TextFrame.WordWrap = msoFalse
        With .TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignCenter  '정렬
            .Font.Color.RGB = rgbWhite                  '글자색
            .Font.Bold = msoTrue                        '진하게
            .Font.Size = 20                             '글자크기
            .Font.Name = "Fixedsys"                     '폰트
        End With
        With .TextFrame2.TextRange.Font
            .Spacing = 0
            .Fill.TwoColorGradient msoGradientHorizontal, 2
            .Fill.ForeColor.RGB = rgbGray
            .Fill.BackColor.RGB = rgbWhite

            .Shadow.Visible = msoTrue
            .Shadow.Type = msoShadow1
            .Shadow.Size = 1
            .Shadow.Blur = 1
            .Shadow.OffsetX = 1
            .Shadow.OffsetY = 1
            .Shadow.Transparency = 0.5
        End With
        
        With .ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "PauseTimer"
        End With
    End With
End Function

'// 슬라이드의 시계도형 모두 삭제
Function RemoveAllClocks()

    Dim sld As Slide
    
    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 Function

'// 해당 슬라이드에 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

'//not used, get gradientstops of the current shape fill
Sub getGradient()
 
    Dim shp As Shape
    Dim i As Integer
    
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    With shp.TextFrame2.TextRange.Font.Fill.GradientStops
        For i = 1 To .Count
            Debug.Print .Item(i).Color.RGB, .Item(i).Position
        Next i
    End With
End Sub

'// 최초에 한번 실행해주세요.
Sub FirstRun()
    
    Dim sld As Slide
    Dim shp As Shape
    
    RemoveAllClocks
    
    Set sld = ActivePresentation.Slides(1)
    '//OnSlideShowPageChange 가 잘 실행되도록 Label을 하나 추가합니다.
    If Not shpExist(sld, "Label1") Then
        
        Set shp = sld.Shapes.AddOLEObject(Left:=0, Top:=-200, _
            Width:=100, Height:=20, ClassName:="Forms.Label.1")
        shp.Name = "Label1"
        shp.OLEFormat.Object.Caption = "[지우지 마세요]"
        shp.OLEFormat.Object.Font.Size = 9
        shp.OLEFormat.Object.BackStyle = 0
    End If
End Sub

 

아래 첨부파일 받아주세요.

ClockAlwaysOn2.pptm
0.07MB

 

 

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

 

 

처음 시작은 정지된 상태이므로 우측상단 시계도형을 한번 클릭하면 타이머를 시작합니다.

코드는 몇줄 수정하였습니다.

더보기 
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"         '시간 도형의 이름
Public Pause As Boolean                     '타이머 일시정지용
Public Blink 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
    With sld.Shapes(ClockName).TextFrame2.TextRange
        If Not Blink Then
            Tick = Tick + 1
            '.Text = Format(Time, "hh:mm:ss")
            .Text = Format(TimeSerial(0, 0, Tick), "hh:mm:ss")
            
        Else
            .Characters(3, 1).Font.Fill.Transparency = 0.95
            .Characters(6, 1).Font.Fill.Transparency = 0.95
        End If
    End With
    Blink = Not Blink
    
End Sub


'// 타이머를 시작 - 슬라이드 쇼 종료전 반드시 StopTimer(KillTimer) 해줘야 함.
Function StartTimer()
    If TimerID = 0& Then                                    ' 타이머 ID가 비어 있으면 타이머 시작
        Tick = 0&
        Pause = True                                        ' 처음 시작시 시계를 누를 때까지 일단 정지
        TimerID = SetTimer(0&, 0&, 500&, AddressOf myTimer)  ' 세번째 인수가 인터벌 간격(1000 = 1초)
    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
    
    RemoveAllClocks
    
End Sub

'// 슬라이드가 시작하면 자동으로 타이머 시작
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
    Dim sld As Slide
    
    Set sld = SSW.View.Slide
    
    '라벨 없으면 하나 추가
    If sld.SlideIndex = 1 Then FirstRun
    'Clock 도형이 없으면 생성
    If Not shpExist(sld, ClockName) Then AddClock
    myTimer
    
    'Pause = False
    StartTimer

End Sub

'// 현재 슬라이드에 시계 도형을 추가
Function AddClock()
    Dim sld As Slide
    Dim shp As Shape
    Dim SW As Single
    
    Set sld = ActivePresentation.SlideShowWindow.View.Slide
    If shpExist(sld, ClockName) Then Exit Function
    SW = ActivePresentation.PageSetup.SlideWidth
    With sld.Shapes.AddShape(msoShapeRoundedRectangle, SW - 100, 0, 100, 30)
        .Name = ClockName
        .Adjustments(1) = 0.1                           '둥근 곡률
        .Fill.ForeColor.RGB = rgbLightGray              '배경색
        .Fill.Transparency = 0.8                        '투명도
        .Line.Visible = msoFalse                        '윤곽선
        .TextFrame.WordWrap = msoFalse
        With .TextFrame.TextRange
            .ParagraphFormat.Alignment = ppAlignCenter  '정렬
            .Font.Color.RGB = rgbWhite                  '글자색
            .Font.Bold = msoTrue                        '진하게
            .Font.Size = 20                             '글자크기
            .Font.Name = "Fixedsys"                     '폰트
        End With
        With .TextFrame2.TextRange.Font
            .Spacing = 0
            .Fill.TwoColorGradient msoGradientHorizontal, 2
            .Fill.ForeColor.RGB = rgbGray
            .Fill.BackColor.RGB = rgbWhite

            .Shadow.Visible = msoTrue
            .Shadow.Type = msoShadow1
            .Shadow.Size = 1
            .Shadow.Blur = 1
            .Shadow.OffsetX = 1
            .Shadow.OffsetY = 1
            .Shadow.Transparency = 0.5
        End With
        
        With .ActionSettings(ppMouseClick)
            .Action = ppActionRunMacro
            .Run = "PauseTimer"
        End With
    End With
End Function

'// 슬라이드의 시계도형 모두 삭제
Function RemoveAllClocks()

    Dim sld As Slide
    
    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 Function

'// 해당 슬라이드에 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

'//not used, get gradientstops of the current shape fill
Sub getGradient()
 
    Dim shp As Shape
    Dim i As Integer
    
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    With shp.TextFrame2.TextRange.Font.Fill.GradientStops
        For i = 1 To .Count
            Debug.Print .Item(i).Color.RGB, .Item(i).Position
        Next i
    End With
End Sub

'// 최초에 한번 실행해주세요.
Sub FirstRun()
    
    Dim sld As Slide
    Dim shp As Shape
    
    RemoveAllClocks
    
    Set sld = ActivePresentation.Slides(1)
    '//OnSlideShowPageChange 가 잘 실행되도록 Label을 하나 추가합니다.
    If Not shpExist(sld, "Label1") Then
        
        Set shp = sld.Shapes.AddOLEObject(Left:=0, Top:=-200, _
            Width:=100, Height:=20, ClassName:="Forms.Label.1")
        shp.Name = "Label1"
        shp.OLEFormat.Object.Caption = "[지우지 마세요]"
        shp.OLEFormat.Object.Font.Size = 9
        shp.OLEFormat.Object.BackStyle = 0
    End If
End Sub

 

파일 다운로드:

ClockAlwaysOn2Timer.pptm
0.05MB

 

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

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

파워포인트 2019에서 달라진, 추가된 기능들 요약  (0) 2020.04.01
도넛모양 다이아그램 만들기  (0) 2020.03.11
여러개의 빈줄이 있는 슬라이드 자동 추가  (0) 2020.03.05
PPT 표(Table) 서식 복사/적용  (11) 2020.01.27
PPT 실시간 시계 또는 타이머 추가  (26) 2019.12.17
PPT 한글, 영문 폰트 및 기타 속성 일괄 변경하기  (19) 2019.10.29
파워포인트에서 메뉴-서브메뉴 시스템 구현  (1) 2019.09.05
여러 PPT안의 특정 단어 검색(도형 및 VBA 코드 포함 검색)  (7) 2019.07.07

티스토리툴바