先日のVBA用のストップウォッチクラスを修正しました。
前回からの変更内容
前回はストップウォッチクラスを思うがままに作ってみました。
ところが改めて調べてみると、他言語で使われているストップウォッチクラスは実在するストップウォッチと同じインターフェースを備えているらしいことが分かった。
そこで私も大衆に習って同じ構成の作り方をしてみることにした。
また、64bit版Officeで簡単な動作検証も行い、問題ないことを確認しました。
前回の機能一覧
| プロシージャ | 機能説明 |
|---|---|
| StartTimer | スタート：リセットして計測を開始 |
| ClearTimer | クリア：リセットして他の機能を封印 |
| PauseTimer | 停止：停止時間を記憶 |
| ResumeTimer | 再開：計測を再開 |
| SplitTime | スプリット：開始からの経過時間 |
| LapTime | ラップ：直前の計測からの経過時間 ※スプリットの影響は受けない。 |
| Laps | ラップした時間の配列 |
変更後の機能一覧
| プロシージャ | 日本語名 | 機能説明 |
|---|---|---|
| Start | スタート／再開 | 計測を開始 |
| Reset | リセット | 時間を初期化 |
| Pause | ポーズ／停止 | 停止時間を記憶 |
| SplitTime | スプリット | 開始からの経過時間 |
| LapTime | ラップ | 直前の計測からの経過時間 ※スプリットの影響は受けない。 |
| Laps | ラップス | ラップした時間の配列 |
ストップウォッチクラス ソースコード
clsStopWatch
Option Explicit '高機能ストップウォッチクラス 'Byことりちゅん ' 'ver 1.0 : 2019/2/3 : 当初 https://www.excel-chunchun.com/entry/2019/02/03/233535 'ver 2.0 : 2019/2/5 : 大幅な仕様変更 https://www.excel-chunchun.com/entry/2019/02/05/014303 'ver 2.1 : 2019/2/7 : APIを変更 Private Const CLASS_NAME = "clsTimer" '※エラーコードは適当 Private Const NOSTART_ERROR_CODE = 8001 Private Const NORESET_ERROR_CODE = 8002 Private Const NOSTART_ERROR_MESSAGE = "タイマーが開始されていません。" Private Const NORESET_ERROR_MESSAGE = "タイマーが初期化されていません。" Private StartNum As Long Private LapNum As Long Private PauseNum As Long '停止時間の一時記憶変数 Private LapTimes As Collection Private DefaultFormat As String #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong #Else Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long #End If #Else Private Declare Function GetTickCount Lib "kernel32" () As Long #End If #If VBA7 Then Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long #Else Private Declare Function timeGetTime Lib "winmm.dll" () As Long #End If '面倒なので32bitと64bitの型を揃える Public Function GetTime() As Long '#If Win64 Then ' GetTime = CLng(GetTickCount64) '#Else ' GetTime = GetTickCount '#End If GetTime = timeGetTime() End Function '初期化 Private Sub Class_Initialize() Call Reset End Sub 'スタート：計測を開始／再開 Public Sub Start(Optional defFormat As String = "") If defFormat <> "" Then DefaultFormat = defFormat '停止していた時間分を開始時間に足すことで辻褄をあわせる StartNum = StartNum + (GetTime - PauseNum) LapNum = LapNum + (GetTime - PauseNum) PauseNum = 0 End Sub 'リセット：全ての時間を初期化 Public Sub Reset() StartNum = 0 LapNum = 0 PauseNum = 0 Set LapTimes = New Collection End Sub 'ポーズ：一時停止し停止時間を記憶 Public Sub Pause() If StartNum = 0 Then Err.Raise NOSTART_ERROR_CODE, CLASS_NAME, NOSTART_ERROR_MESSAGE PauseNum = GetTime End Sub 'スプリット：開始からの経過時間 Public Function SplitTime(Optional ByVal timeFormat As String = "") As Variant If StartNum = 0 Then Err.Raise NOSTART_ERROR_CODE, CLASS_NAME, NOSTART_ERROR_MESSAGE Dim tm As Long tm = (GetTime - StartNum) If timeFormat = "" Then timeFormat = DefaultFormat If timeFormat = "" Then SplitTime = tm Else SplitTime = GetTimeFormat(tm, timeFormat) End If End Function 'ラップ：直前の計測からの経過時間 Public Function LapTime(Optional ByVal timeFormat As String = "") As Variant If StartNum = 0 Then Err.Raise NOSTART_ERROR_CODE, CLASS_NAME, NOSTART_ERROR_MESSAGE Dim tm As Long tm = (GetTime - LapNum) LapNum = GetTime If timeFormat = "" Then timeFormat = DefaultFormat If timeFormat = "" Then LapTime = tm Else LapTime = GetTimeFormat(tm, timeFormat) End If LapTimes.Add LapTime End Function 'ラップタイムのコレクションを返す Public Property Get Laps() As Variant If StartNum = 0 Then Err.Raise NOSTART_ERROR_CODE, CLASS_NAME, NOSTART_ERROR_MESSAGE If LapTimes.Count = 0 Then Laps = Split(vbNullString) Else Dim Arr() As Variant ReDim Arr(1 To LapTimes.Count) Dim i As Long For i = 1 To LapTimes.Count Arr(i) = LapTimes(i) Next Laps = Arr End If End Property 'ミリセコンドから任意の書式に変換 Private Function GetTimeFormat(tm As Long, timeFormat As String) As Variant Select Case True Case timeFormat = "s" GetTimeFormat = CDbl(tm) / 1000 Case timeFormat = "ms" GetTimeFormat = tm Case timeFormat Like "*ms" GetTimeFormat = Right(String(10, " ") & Format(tm, timeFormat), 10) Case timeFormat Like "*s" GetTimeFormat = Right(String(10, " ") & Format(CDbl(tm) / 1000, timeFormat), 10) Case Else GetTimeFormat = Format(tm, timeFormat) End Select End Function
検証用プロシージャ ソースコード
任意のモジュール(clsStopWatch_test等)
Option Explicit 'clsStopWatch検証用プロシージャ Sub Test_StopWatch() Const TEST_COUNT = 5 Const TEST_ROWS = 10000 Const TEST_FORMAT = "0ms" Const TEST_SHEET = "StopWatchTest" '一時シートの生成 ActiveWorkbook.Worksheets.Add Dim Ws As Worksheet Set Ws = ActiveWorkbook.ActiveSheet Ws.Name = TEST_SHEET '必要な変数宣言 Dim cSW As clsStopWatch Set cSW = New clsStopWatch Dim i As Long, j As Long '以下メイン処理 Debug.Print "-----個別出力-----" cSW.Start TEST_FORMAT For i = 1 To TEST_COUNT Ws.Cells.Clear For j = 1 To TEST_ROWS Ws.Cells(j, 1).Value = "個別出力だああああ" Next Debug.Print "ラップ：" & cSW.LapTime() & "" Next Debug.Print "合計 ：" & cSW.SplitTime() & "" '中断・再開の検証、及びラップ一覧の表示 cSW.Pause MsgBox "ラップ一覧" & vbLf & Join(cSW.Laps, vbLf), vbOKOnly, "個別出力" cSW.Start 'メッセージボックス表示中の時間が進んでなければOK Debug.Print "中断後：" & cSW.SplitTime() & "" 'タイマーの初期化 cSW.Reset Debug.Print "-----一括出力-----" cSW.Start TEST_FORMAT For i = 1 To TEST_COUNT Ws.Cells.Clear Ws.Cells(1, 1).Resize(TEST_ROWS, 1).Value = "一括出力だああああ" Debug.Print "ラップ：" & cSW.LapTime() & "" Next Debug.Print "合計 ：" & cSW.SplitTime() & "" cSW.Pause MsgBox "ラップ一覧" & vbLf & Join(cSW.Laps, vbLf), vbOKOnly, "一括出力" cSW.Start Debug.Print "中断後：" & cSW.SplitTime() & "" '一時シートの削除 On Error Resume Next Application.DisplayAlerts = False ActiveWorkbook.Worksheets(TEST_SHEET).Delete Application.DisplayAlerts = True On Error GoTo 0 End Sub
検証風景
まとめ
ストップウォッチクラスの修正版でした。
なんか前のよりソースコードが遥かにシンプルになったような・・・。やはり先人の知恵は正しかったのだ。
これで問題ないかどうかは、しばらく使いながら考えて行きたいと思います。
以上
何か御座いましたらコメント欄、またはTwitterからどうぞ♪
それではまた来週♪ ちゅんちゅん(・8・)
