えくせるちゅんちゅん

ことりがエクセルをちゅんちゅんするブログ

VBAでストップウォッチクラスを作ってみた part2

先日のVBA用のストップウォッチクラスを修正しました。


前回からの変更内容

前回はストップウォッチクラスを思うがままに作ってみました。

kotori-chunchun.hatenablog.com

ところが改めて調べてみると、他言語で使われているストップウォッチクラスは実在するストップウォッチと同じインターフェースを備えているらしいことが分かった。

そこで私も大衆に習って同じ構成の作り方をしてみることにした。

また、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://kotori-chunchun.hatenablog.com/entry/2019/02/03/233535
'ver 2.0 : 2019/2/5 : 大幅な仕様変更  https://kotori-chunchun.hatenablog.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

検証風景

f:id:Kotori-ChunChun:20190203232247g:plain

まとめ

ストップウォッチクラスの修正版でした。

なんか前のよりソースコードが遥かにシンプルになったような・・・。やはり先人の知恵は正しかったのだ。

これで問題ないかどうかは、しばらく使いながら考えて行きたいと思います。

以上


何か御座いましたらコメント欄、またはTwitterからどうぞ♪

週1回の更新を目指して、頑張ってますので応援よろしくおねがいします!

それでは、また今度♪ ちゅんちゅん(・8・)