sample_PPT_DigitalSignage.bas

Option Explicit

Const IntervalSld As Double = 2.5 'スライド切替時間[sec]
Const NumSelectSld As Long = 3 '日ごとに選択するスライド総数

Dim d0 As Date 'マクロ開始時の日付
Dim j0 As Long '日付d0での選択スライドの番号

'スライドショー実行（メイン）
Sub MainLoop()
    Dim i As Long
    Dim sld As Slide
    
    d0 = Date
    j0 = InputBox(Prompt:= _
        "今日は " & d0 & " です" & vbCrLf & _
        "今日の選択スライド番号を入力してください。（1～" & NumSelectSld & "）")
    If j0 < 1 Or j0 > NumSelectSld Then
        MsgBox ("正しい値ではないので終了します")
        Exit Sub
    End If
    
    With ActivePresentation.Slides
        .Item(.Count).Shapes(1).TextFrame.TextRange.Text = d0 
        .Item(.Count).Shapes(2).TextFrame.TextRange.Text = j0
        '最後のスライドに書き込む、Shapesの番号は調整が必要
    End With
    
    Debug.Print "初期d0 : " & d0
    Debug.Print "初期j0 : " & j0
    Debug.Print "スライド総数 : " & ActivePresentation.Slides.Count
    Debug.Print "選択スライド総数 : " & NumSelectSld & " + 1"
    
    For Each sld In ActivePresentation.Slides
        With sld.SlideShowTransition
            .Hidden = msoFalse
            '非表示スライドの初期化（全て表示スライド）
            
            .AdvanceOnClick = msoTrue
            .AdvanceOnTime = msoTrue
            .AdvanceTime = IntervalSld
            '切替時間の設定
        End With
    Next sld
    
    With ActivePresentation.SlideShowSettings
        .LoopUntilStopped = msoTrue 'ループさせる
        .Run 'スライドショー実行
    End With
End Sub

'スライドショー実行中に非表示スライドを設定
Sub OnSlideShowPageChange(ByVal ss As SlideShowWindow)
    Dim n As Long, i As Long
    Dim d1 As Date
    
    n = ss.View.CurrentShowPosition
    
    With ActivePresentation.Slides
        If n = .Count - (NumSelectSld + 1) Then
            '選択スライド群に入る前のスライドに来たら以下の設定開始
            '最後のスライドは前回の番号を記録したもの
            DoEvents
                
            For i = n + 1 To .Count
                .Item(i).SlideShowTransition.Hidden = msoTrue '一旦日ごと部分を全て非表示
            Next i
                
            d1 = Date
            
            If d0 <> d1 Then
                d0 = d1
                j0 = (j0 Mod NumSelectSld) + 1
                '日付が変わっている場合にd0、j0更新
                    
                .Item(.Count).Shapes(1).TextFrame.TextRange.Text = d0
                .Item(.Count).Shapes(2).TextFrame.TextRange.Text = j0
                '最後のスライドに書き込む
            End If
                
            .Item(.Count - (NumSelectSld + 1) + j0).SlideShowTransition.Hidden = msoFalse
            '選択スライドを表示
        End If
    End With
End Sub