[VBA] タイマー起動 と アナログ時計作成

Excel と VBA による周期イベントタイマーの使い方を記載してみます。

この手法を使って、デジタル時計とアナログ時計を作成してみます。

 

 

 

こんな感じのものを作成します。

 

 

1. OnTime によるタイマー起動

[概要]

まず最初に、もっとも標準的な Application.OnTime を使って１秒周期で関数を起動する VBA プログラムを作成してみます。

ここでは１秒周期で "A1" セルに現在の日時情報を表示してみます。

 

[環境]

Microsoft Excel 2021 MSO (バージョン 2307 ビルド 16.0.16626.20170) 64 ビット

 

VBAコードを以下に示します。下記例では "Microsoft ExcelObjects" > "Sheet1" に作成しています。

'
' Application.OnTime を使った周期動作により、デジタル時計 を作成してみます
'

Option Explicit

Private mOnTime As Date


'
' デジタル時計を表示する
'
Private Sub TimerProc()

  Range("A1") = Format(Now, "yyyy/mm/dd hh:mm:ss")

End Sub


'
' 周期タイマー起動
'
Sub OnTimeStart()
    
    ' デジタル時計 表示更新
    Call TimerProc
    
    ' 次回のタイマー起動を設定 － "Now + TimeSerial(0, 0, 1)" は 現在時刻から１秒後 を意味します。
    mOnTime = Now + TimeSerial(0, 0, 1)
    Call Application.OnTime(mOnTime, "Sheet1.OnTimeStart")
    
End Sub


'
' 周期タイマー停止
'
Sub OnTimeStop()

    ' 同一の Procedure と EarliestTime がないとエラーになる
    On Error Resume Next
    Call Application.OnTime(mOnTime, "Sheet1.OnTimeStart", , False)
    
End Sub

 

Sheet1 上にボタンを作成して、スタート／ストップをそれぞれ Sheet1.OnTimeStart／Sheet1.OnTimeStop を実行するようにすると、下記動画のように動作します。

 

１秒周期で画面更新することができました。これを応用することで簡単な動画やゲームなどを実現することもできそうです。

ところでマウスカーソルが時々 Wait 表示になるところが若干気になります。次章で紹介する SetTimer (Windows API) を使うとこの問題を解決できます。

 

 

2. SetTimer によるタイマー起動

[概要]

SetTimer, KillTimer API (Windows API) を使って１秒周期で関数を起動する VBA プログラムを作成してみます。

前章同様に１秒周期で "A1" セルに現在の日時情報を表示してみます。

 

[環境]

Microsoft Excel 2021 MSO (バージョン 2307 ビルド 16.0.16626.20170) 64 ビット

 

 

VBAコードを以下に示します。下記例では "Microsoft ExcelObjects" > "Sheet2" に作成しています。

'
' Win32 API の SetTimer, KillTimer を使った周期動作により、デジタル時計、アナログ時計を作成してみます。
'

Option Explicit


'
' デジタル時計を表示する
'
Sub TimerProc()
  Range("A1") = Format(Now, "yyyy/mm/dd hh:mm:ss")
End Sub


'
' 周期タイマー起動
'
Sub TimerStart()

    If mTimerID <> 0 Then
        MsgBox "起動済です。"
        Exit Sub
    End If
    
    Call StartTimer
    
End Sub


'
' 周期タイマー停止
'
Sub TimerStop()

    Call StopTimer
    
End Sub

 

下記コードを "標準モジュール" > "Module1" に記載します。

'
' Win32 API の SetTimer, KillTimer を使って周期動作を実現してみます。
' 下記内容は Sheet2 のためのVBAプログラムです。
' Sheet2 内で全てを実現したかったのですが、標準モジュール（Module1）内で記載しないと意図通りに動作してくれませんでした。残念。
'

Option Explicit

Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long

                                        
Public mTimerID As Long


Private Sub TimerProc()

    If mTimerID = 0 Then End    '終了できない時の対策
    On Error Resume Next        'デバッグ出すとExcelが固まるので
    
    Call Sheet2.TimerProc
    
End Sub


'
' SetTimer API を使って周期タイマー動作を開始する
'
Public Sub StartTimer()

    mTimerID = SetTimer(0&, 1&, 1000&, AddressOf TimerProc)
    
End Sub


'
' KillTimer API を使って周期タイマー動作を停止する
'
Public Sub StopTimer()

    Call KillTimer(0&, mTimerID)
    mTimerID = 0
    
End Sub

 

Sheet2 上にボタンを作成して、スタート／ストップをそれぞれ Sheet2.TimerStart／Sheet2.TimerStop を実行するようにすると、下記動画のように動作します。

 

OnTime による実現と異なってマウスカーソルが Wait 状態に頻繁になることが無くなりました。良い感じです。

一方、SetTimer, KillTimer を標準モジュール内で使用する必要がありました。Sheet2 内で使用したかったのですが私はうまく実現することができませんでした。

 

ポイント

SetTimer, KillTimer を標準モジュール内で実行する必要がありました。

Sheet2 内で完結したプログラムにしたかったのですが、私がトライした範疇ではこれらAPIを Sheet2 内で実行すると、Excel が異常終了するなどしてうまく実現することができませんでした。

何か良い方法がわかったらこちら記事を更新したいと思います。

 

 

3. アナログ時計を作成する

[概要]

上記タイマーイベントを使用してアナログ時計を作成します。完成イメージは下図動画の通りです。

 

[環境]

Microsoft Excel 2021 MSO (バージョン 2307 ビルド 16.0.16626.20170) 64 ビット

 

 

3-1. アナログ時計を描く

最初にアナログ時計の絵を描きます。

 

ポイント

  • "00:00:00" となるように描きます。
    各針の位置を Rotation で指示するので、初期位置を "00:00:00" にしておく必要があります。

 

アナログ時計を描く

 

 

3-2. 各針に名前を付ける

各針に名称を付けます。本ページで紹介するプログラムで付与した名称を下記 table に記載します。

 

[table.] 各針の名称
針 名称
秒針 "second_line"
分針（長針） "minute_line"
時針（短針） "hour_line"

 

 

3-3. 秒針を動かす

指定した秒数に従って秒針を動かす関数を作成します。

 

ポイント

  • 秒針の位置指定を Rotation を使って実現します。
  • Rotation は図の中心を軸に回転します。残念ながら回転中央を任意の位置に指定することができません。
    そこで、回転中央としたい場所が図の中心になるように秒針の高さを一旦２倍にします。Rotation を使って意図する角度に回転した後、秒針の高さを元の高さ（0.5倍）に戻す、という方法で実現します。
  • 秒針の描画テスト用に、関数 test_AnalogTimer を作成します。これを実行することでテスト＆デバッグします。

 

 

'
' 針（shape）の高さを rate 倍する
'
Private Sub ScaleHeight_Update(shape As shape, rate As Double)

    shape.ScaleHeight rate, msoFalse

End Sub


'
' 秒針を更新
'
Private Sub UpdateSecond(second As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("second_line")
    rate = 0.5
    
    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = second * 360 / 60
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)
    
End Sub


'
' アナログ時計の表示テスト用
'
Sub test_AnalogTimer()

    UpdateSecond (10)

End Sub

 

上記 "test_AnalogTimer()" を実行した結果は下図の通りです。値を適当に変更しつつ、テスト＆デバッグを行います。

test_AnalogTimer() の実行結果

 

 

3-4. 分針（長針）を動かす

指定した分数に従って分針を動かす関数を作成します。

秒針とほぼ同じ処理なので、詳細説明を割愛します。

 

'
' 分針を更新
'
Private Sub UpdateMinute(minite As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("minute_line")
    rate = 0.55
    
    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = minite * 360 / 60
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)
    
End Sub

 

 

3-5. 時針（短針）を動かす

指定した時数に従って時針を動かす関数を作成します。

秒針とほぼ同じ処理なので、詳細説明を割愛します。

 

'
' 時針を更新
'
Private Sub UpdateHour(hour As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("hour_line")
    rate = 0.55

    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = hour * 360 / 12
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)

End Sub

 

 

3-6. 現在時刻に従ってアナログ時計を更新する

現在時刻に従ってアナログ時計を更新する関数を作成します。

 

'
' アナログ時計を現在時間に従って表示する
'
Private Sub AnalogTimerProc()

    Dim dateTime As Date
    Dim h As Double
    Dim m As Double
    Dim s As Double
    
    dateTime = Now()
    h = hour(dateTime)
    m = minute(dateTime)
    s = second(dateTime)
    
    UpdateHour (h + (m / 60) + (s / 3600))
    UpdateMinute (m + (s / 60))
    UpdateSecond (s)

End Sub

 

 

3-7. １秒周期で現在時刻を更新する

最後に１秒周期で現在時刻を更新するようにします。

１章、２章、で作成した周期イベントの中から上記関数 AnalogTimerProc() をコールするだけです。

 

１章の内容（Sheet1）にアナログ時計表示を加えた全ソースコードを以下に記載します。

 

'
' Excel VBA の Application.OnTime を使った周期動作により、デジタル時計、アナログ時計を作成してみます。
'

Option Explicit

Private mOnTime As Date


'
' デジタル時計を表示する
'
Private Sub TimerProc()

  Range("A1") = Format(Now, "yyyy/mm/dd hh:mm:ss")

End Sub


'
' 周期タイマー起動
'
Sub OnTimeStart()
    
    ' デジタル時計 表示更新
    Call TimerProc
    
    ' アナログ時計 表示更新
    Call AnalogTimerProc
    
    ' 次回のタイマー起動を設定
    mOnTime = Now + TimeSerial(0, 0, 1)
    'Tm = 200
    'mOnTime = [Now()] + Tm / 86400000
    Call Application.OnTime(mOnTime, "Sheet1.OnTimeStart")
    
End Sub


'
' 周期タイマー停止
'
Sub OnTimeStop()

    ' 同一の Procedure と EarliestTime がないとエラーになる
    On Error Resume Next
    Call Application.OnTime(mOnTime, "Sheet1.OnTimeStart", , False)
    
End Sub


'
' === 以下、アナログ時計用の処理 ===
'

'
' 針（shape）の高さを rate 倍する
'
Private Sub ScaleHeight_Update(shape As shape, rate As Double)

    shape.ScaleHeight rate, msoFalse

End Sub


'
' 時針を更新
'
Private Sub UpdateHour(hour As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("hour_line")
    rate = 0.55

    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = hour * 360 / 12
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)

End Sub


'
' 分針を更新
'
Private Sub UpdateMinute(minite As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("minute_line")
    rate = 0.55
    
    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = minite * 360 / 60
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)
    
End Sub


'
' 秒針を更新
'
Private Sub UpdateSecond(second As Double)

    Dim shp As shape
    Dim rate As Double
    
    Set shp = Sheet1.Shapes("second_line")
    rate = 0.5
    
    ' 元の長さにする
    Call ScaleHeight_Update(shp, 1# / rate)
    
    ' 回転する
    shp.Rotation = second * 360 / 60
    
    ' 長さを半分ぐらいにする
    Call ScaleHeight_Update(shp, rate)
    
End Sub


'
' アナログ時計を現在時間に従って表示する
'
Private Sub AnalogTimerProc()

    Dim dateTime As Date
    Dim h As Double
    Dim m As Double
    Dim s As Double
    
    dateTime = Now()
    h = hour(dateTime)
    m = minute(dateTime)
    s = second(dateTime)
    
    UpdateHour (h + (m / 60) + (s / 3600))
    UpdateMinute (m + (s / 60))
    UpdateSecond (s)

End Sub


'
' アナログ時計の表示テスト用
'
Sub test_AnalogTimer()

    UpdateHour (10)
    UpdateMinute (10)
    UpdateSecond (30)

End Sub

 

 

 

 

ダウンロード

上記で作成した Excel ファイルを こちら からダウンロードできます。

 

 

ライセンス

本ページの情報は、特記無い限り下記 MIT ライセンスで提供されます。

The MIT License (MIT)

  Copyright 2023 Kinoshita Hidetoshi

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

 


参考

 

 

変更履歴

2023-08-19 - 新規作成

 

Programming Items トップページ

プライバシーポリシー