えくせるちゅんちゅん

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

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

今回はVBA用のストップウォッチクラスを紹介します。


何番煎じですか

ストップウォッチと聞いて、

「はいはい。時間計測用のクラスね。何番煎じですか」

って思った貴方。

本当にVBAストップウォッチクラスを見たことありますか?

私が求めているのは時間計測ではありません。

あくまでストップウォッチなのです。

ちゃんと一時停止と再開ができて、ラップタイムとかを取得できるものです。

私は見たことがありません。

(ほとんど検索してないので、ちゃんと探せばありそうですが)

ストップウォッチってなんだっけ?

ここまでの煽りは軽く流していただいて、ストップウォッチにはどんな機能があったか思い出してみましょう。

ま、万年文化系の部活だった私には、縁のない機械なんですけどね。

(たぶん一番流通している)ストップウォッチの機能

  1. ボタン1:スタート/停止/再開
  2. ボタン2:ラップ/スプリット表示
  3. ボタン1+2:リセット

かな?今はもっと進化してるのかもしれないけれど。

実務上のプログラムのベンチマークをする時は、どうしても計測に含めたく無いノイズが混ざってしまいます。

だから特定区間の時間を計測するためには、そこそこ面倒な計算をしなければなりません。

普通のストップウォッチなら一時停止が出来るので対応できますよね。

例えばこんなイメージです。

Sub 例えばこういうの()
    
    Dim i As Long, j As Long, k As Long
    Dim Ws As Worksheet
    Dim V As Variant
    
    'ストップウォッチを開始
    
    For Each Ws In ThisWorkbook.Worksheets
    
        '計測ここから
        For i = 1 To 100
            For j = 1 To 100
                V = Ws.Cells(i, j)
            Next
        Next
        '計測ここまで
        
        'ストップウォッチを一時停止
        
        '計測に含めたくない重い処理
        MsgBox "適当に待ち時間"
        
        'ストップウォッチを再開
    
        '計測ここから
        For i = 1 To 100
            For j = 1 To 100
                V = Ws.Cells(i, j)
            Next
        Next
        '計測ここまで
        
    Next
    
    'ストップウォッチを終了
    
    MsgBox "それぞれの計測結果を表示"
    
End Sub

とにかく私は、こういった機能まで備えたストップウォッチクラスが欲しかったので作りました。

機能説明

実在するストップウォッチのインターフェースと同じように組むことも出来るのですが、VBAで使うとなると見直したほうが良さそうです。

そこで私はこのような機能を持たせました。

プロシージャ 機能説明
StartTimer スタート:リセットして計測を開始
ClearTimer クリア:リセットして他の機能を封印
PauseTimer 停止:停止時間を記憶
ResumeTimer 再開:計測を再開
SplitTime スプリット:開始からの経過時間
LapTime ラップ:直前の計測からの経過時間
※スプリットの影響は受けない。
Laps ラップした時間の配列

クリアは正直必要ないと思うんですけどね。

インスタンス作り直せばいいし・・・。

ストップウォッチクラス ソースコード

clsStopWatch

Option Explicit

'高機能ストップウォッチクラス (64bit暫定対応。動作未検証)
'Byことりちゅん
'https://www.excel-chunchun.com/entry/2019/02/03/233535
'
'ver 1.0 : 2019/2/3 当初

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

'スタート:リセットして計測を開始
Public Sub StartTimer(Optional defFormat As String = "")
    If StartNum <> 0 Then Err.Raise NORESET_ERROR_CODE, CLASS_NAME, NORESET_ERROR_MESSAGE
    DefaultFormat = defFormat
    
#If Win64 Then
    StartNum = CLng(GetTickCount64)
#Else
    StartNum = GetTickCount
#End If
    LapNum = StartNum
    PauseNum = 0
    Set LapTimes = New Collection
    
End Sub

'クリア:リセットして機能を使えないようにする
Public Sub ClearTimer()
    StartNum = 0
    LapNum = 0
    PauseNum = 0
    Set LapTimes = Nothing
End Sub

'ポーズ:一時停止:停止時間を記憶
Public Sub PauseTimer()
    If StartNum = 0 Then Err.Raise NOSTART_ERROR_CODE, CLASS_NAME, NOSTART_ERROR_MESSAGE
    
#If Win64 Then
    PauseNum = CLng(GetTickCount64)
#Else
    PauseNum = GetTickCount
#End If

End Sub

'リズム:再開:停止していた時間分を開始時間に足すことで辻褄をあわせる
Public Sub ResumeTimer()
    If PauseNum = 0 Then Exit Sub   '非ポーズ中
    
#If Win64 Then
    StartNum = StartNum + (CLng(GetTickCount64) - PauseNum)
    LapNum = LapNum + (CLng(GetTickCount64) - PauseNum)
#Else
    StartNum = StartNum + (GetTickCount - PauseNum)
    LapNum = LapNum + (GetTickCount - PauseNum)
#End If
    PauseNum = 0
    
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
    
#If Win64 Then
    tm = CLng(GetTickCount64 - StartNum)
#Else
    tm = (GetTickCount - StartNum)
#End If
    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
    
#If Win64 Then
    tm = CLng(GetTickCount64 - LapNum)
    LapNum = CLng(GetTickCount64)
#Else
    tm = (GetTickCount - LapNum)
    LapNum = GetTickCount
#End If
    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 = 100
    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.StartTimer 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.PauseTimer
    MsgBox "ラップ一覧" & vbLf & Join(cSW.Laps, vbLf), vbOKOnly, "個別出力"
    cSW.ResumeTimer
    
    'メッセージボックス表示中の時間が進んでなければOK
    Debug.Print "中断後:" & cSW.SplitTime() & ""
    cSW.ClearTimer
    
    
    Debug.Print "-----一括出力-----"
    cSW.StartTimer 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.PauseTimer
    MsgBox "ラップ一覧" & vbLf & Join(cSW.Laps, vbLf), vbOKOnly, "一括出力"
    cSW.ResumeTimer
    
    Debug.Print "中断後:" & cSW.SplitTime() & ""
    cSW.ClearTimer
    
    '一時シートの削除
    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

まとめ

というわけでストップウォッチクラスの紹介でした。

これなら誰に向かっても「ストップウォッチ」って堂々と宣言できますよね!

実は今まで、時間の計測は適当にやっていたのですが、今後はこれに統一していきたいと思います。

=作ったばかりなのでデバッグしきれてないかもしれません。

また、64bit Officeが手元にないので、仮です。後日検証する事ができたら更新します。

以上

追記

大幅に仕様を変更したため別記事にて再投稿しました。(2019/2/5追記)

www.excel-chunchun.com


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

それではまた来週♪ ちゅんちゅん(・8・)

プライバシーポリシー