Powerpoint VBAで作ったカウントダウンタイマーに①一時停止ボタンをつけたい。②スライドごと複製しても使えるようにしたい。

Question

前提

パワーポイントのスライド上にカウントダウンタイマーを表示したいときがあり、
ネットを参考に、作ってみました。

図形をクリックすることで分と秒を指定し、
大きい四角をクリックするとカウントダウンが始まるところまで
出来ました。

](6db2d64d0985d96d5ad9333f1eb87409.png)

実現したいこと

実現したいことが2つあります。

1. カウントダウンの途中で止めることができるよう改造したいのですが、上手く行きません。
2. カウントダウン用スライドを1ファイルの任意の場所に、複数おいても動くようにしたい。

発生している問題・エラーメッセージ

該当のソースコード

Option Explicit
Dim Minutes As Long
Dim Seconds As Long
'Dim tempStop As Boolean

'-----------何分のカウントダウンか設定する--------------------------

Sub SetMinutes()
    If Minutes < 59 Then
        Minutes = Minutes + 1
        Else
        Minutes = 0
    End If
    
    ActivePresentation.Slides(1).Shapes("MinuteShape").TextFrame.TextRange.Text = Minutes & " min"
 Debug.Print (Minutes & ":" & Seconds)
End Sub

'-----------何秒かのカウントダウンか設定する--------------------------

Sub SetSeconds()

    If Seconds < 50 Then
        Seconds = Seconds + 10
    Else
        Seconds = 0
    End If

ActivePresentation.Slides(1).Shapes("SecondsShape").TextFrame.TextRange.Text = Seconds & " s"

Debug.Print (Minutes & ":" & Seconds)
End Sub

'-----------リセットする--------------------------

Sub Reset()
Minutes = 0
Seconds = 0

    ActivePresentation.Slides(1).Shapes("MinuteShape").TextFrame.TextRange.Text = Minutes & " min"
    ActivePresentation.Slides(1).Shapes("SecondsShape").TextFrame.TextRange.Text = Seconds & " s"
Debug.Print (Minutes & ":" & Seconds)
End Sub
'-----------カウントダウン--------------------------
Sub CountDown()

Dim EndTime As Date

'tempStop = False

Seconds = Minutes * 60 + Seconds
EndTime = DateAdd("s", Seconds, Now())

    Do Until EndTime <= Now()
        DoEvents
   
        ActivePresentation.Slides(1).Shapes("TimerShape").TextFrame.TextRange.Text = Format((EndTime - Now()), "nn:ss")
        
'        If tempStop = True Then
'        Exit Sub
'      End If
        
    Loop

End Sub

'Sub JudgeStop()
'
'  tempStop = True
'
'End Sub

試したこと

1については、判定用の変数tempStopを用意し、それがtrueならループを抜けるように書いてみましたが、上手く行きません。

2については、現時点では、スライドの位置(スライド番号)は固定なのが問題だと考え、「ActivePresentation.Slides(1).」の部分を 「ActiveWindow.Selection.SlideRange.」に変更しました。しかし、そうすると、図形を押しても反応しなくなりました。

なにぶん初心者ですので、お手上げです。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Answer 1

1. カウントダウンの途中で止めることができるよう改造したいのですが、上手く行きません。

「途中で止める」という文言から、一時停止し、再スタートすると前回の続きから動作してほしい、という意図だと判断しました。

そのためには、ユーザーの設定したタイマーの時間を保存する変数以外に、途中で止めた場合の残り時間の変数も必要となります。

2.カウントダウン用スライドを1ファイルの任意の場所に、複数おいても動くようにしたい。

まず、クリックされた図形が存在するスライドを特定する方法ですが、大きく2種類の方法があります。

一つ目はウィンドウから辿る方法です。
PowerPointでは編集用のウィンドウ(DocumentWindow)とスライドショー表示のウィンドウ(SlideShowWindow)は別の物です。
「ActiveWindow.Selection.SlideRange.」はDocumentWindowのため、ActivePresentation.SlideShowWindow.View.SlideのようにSlideShowWindowから辿る必要があります。

二つ目は、図形に登録するマクロの引数を使用する方法です。
PowerPoint独自の仕様ですが、図形に登録するマクロに引数を設定すると、1個目の引数にクリックされた図形(PowerPoint.Shape)が渡されます。
確実にクリックされた図形を取得できるため、こちらの方がより確実な方法と思われます。

それ以外にも、タイマーの設定は、全体で共通でよいのか、スライド毎に個別にしたいのかでコードが変わってきます。

---

参考として、マクロの引数から図形を取得し、タイマーの設定を全体で共通とする場合の例です。

変数を管理するのが面倒だったため、MinutesとSecondsをtimerTime_の変数にまとめています。

また「途中で止めた場合の残り時間の変数」としてremainingTime_を用意しています。

Option Explicit

'ユーザーが設定したタイマーの時間
Private timerTime_ As Date

'途中で止めたときの残り時間
Private remainingTime_ As Date

'一時停止用のフラグ
Private isRunning_ As Boolean


'共通処理

'inTimeにinSecond秒足した時間を返す。ただし、1時間を超える分は切り捨てる。
Private Function AddSecondsAndLimit1Hour(inTime As Date, inSecond As Long) As Date
    Dim newTime As Date
    newTime = DateAdd("s", inSecond, inTime)
    
    'Hourを0にすることで、最大でも1時間より小さくなるようにする。
    Let AddSecondsAndLimit1Hour = TimeSerial(0, Minute(newTime), Second(newTime))
End Function

'タイマー部分の図形の表示を更新する
Private Sub UpdateTimerShape(inSld As PowerPoint.Slide, inTime As Date)
    With inSld.Shapes
        .Item("TimerShape").TextFrame.TextRange.Text = Format(inTime, "nn:ss")
    End With
End Sub

'時間設定部分の図形を更新する
Private Sub UpdateSettingShapes(inSld As PowerPoint.Slide, inTime As Date)
    With inSld.Shapes
        .Item("MinuteShape").TextFrame.TextRange.Text = Minute(inTime) & " min"
        .Item("SecondsShape").TextFrame.TextRange.Text = Second(inTime) & " s"
    End With
    UpdateTimerShape inSld, inTime
    
    '時間設定を変えるということは、一時停止の情報をリセットしてもいいという判断
    remainingTime_ = CDate(Empty)
End Sub


'-----------何分のカウントダウンか設定する--------------------------

Sub SetMinutes(inMinuteShape As PowerPoint.Shape)
    '60秒(=1分)足して、図形の表示を更新する。
    timerTime_ = AddSecondsAndLimit1Hour(timerTime_, 60)
    UpdateSettingShapes inMinuteShape.Parent, timerTime_
    
    Debug.Print Format(timerTime_, "nn:ss")
End Sub

'-----------何秒かのカウントダウンか設定する--------------------------

Sub SetSeconds(inSecondsShape As PowerPoint.Shape)
    '10秒足して、図形の表示を更新する。
    timerTime_ = AddSecondsAndLimit1Hour(timerTime_, 10)
    UpdateSettingShapes inSecondsShape.Parent, timerTime_
    
    Debug.Print Format(timerTime_, "nn:ss")
End Sub

'-----------リセットする--------------------------

Sub Reset(inResetShape As PowerPoint.Shape)
    timerTime_ = CDate(Empty)
    UpdateSettingShapes inResetShape.Parent, timerTime_
    
    Debug.Print Format(timerTime_, "nn:ss")
End Sub

'-----------カウントダウン--------------------------
Sub CountDown(inCountDownShape As PowerPoint.Shape)
    If isRunning_ Then
        '個人的にスタートと一時停止はトグル式の方が好みだったのでその対応。
        '実行中に押した場合は停止させる。
        isRunning_ = False
        Exit Sub
    End If
    
    isRunning_ = True
    
    Dim EndTime As Date
    '残り時間が0で無ければその続きから再開。
    If remainingTime_ = CDate(Empty) Then
        EndTime = Now + timerTime_
    Else
        EndTime = Now + remainingTime_
    End If
    
    
    Dim sld As PowerPoint.Slide
    Set sld = inCountDownShape.Parent
    
    Do Until EndTime <= Now
        DoEvents
        remainingTime_ = EndTime - Now
        UpdateTimerShape sld, remainingTime_
        
        If isRunning_ = False Then
            Exit Sub
        End If
    Loop
    
    '終了処理
    remainingTime_ = CDate(Empty)
    isRunning_ = False
    MsgBox "End"
End Sub

Sub JudgeStop()
    isRunning_ = False
End Sub

Comments

[SnowMonkey]

ありがとうございました。私が実現したかったことが完全に実現できています。とてもうれしいです。　こうすればトグル式に切り替えができるんだとか、shape.Parentでスライドを取得(？指定？）するんだとか、解読しながら勉強させていただいています。