HOME > エクセルVBA > サンプル > リボンの君とストップウォッチ

リボンの君とストップウォッチ


【ファイル名】リボンの君とストップウォッチ.xlam
【バージョン】Ver 1.0.0.0
【作成日】2019年04月03日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Stopwatch.zip  VBAのプロジェクトのプロパティ表示のためのパスワードは小文字の「pass」です。
【説明】計測した時間をセルに代入します。(アドインなので頻繁に使用する場合は、ご自分でインストールしてください)

メニュー

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="リボンの君とストップウォッチ.xlam!onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="ストップウォッチ" keytip="S">
        <group id="Group1" label="時間計測">
          <box id="Box1" boxStyle="vertical">
            <button id="StartButton" imageMso="ReadingViewNextPage" label="スタート" keytip="S"
                    getEnabled="リボンの君とストップウォッチ.xlam!getEnabled" supertip="時間の計測を開始します。"
                    onAction="リボンの君とストップウォッチ.xlam!onAction" />
            <button id="StopButton" imageMso="MacroRecorderStop" label="ストップ" keytip="T"
                    getEnabled="リボンの君とストップウォッチ.xlam!getEnabled" supertip="時間の計測を停止します。"
                    onAction="リボンの君とストップウォッチ.xlam!onAction" />
            <button id="ResetButton" imageMso="Delete" label="リセット" keytip="R"
                    getEnabled="リボンの君とストップウォッチ.xlam!getEnabled" supertip="計測した時間をゼロにします。"
                    onAction="リボンの君とストップウォッチ.xlam!onAction" />
          </box>
          <box id="Box2" boxStyle="vertical">
            <labelControl id="labelControl1" getLabel="getLabel" />
            <button id="InsertTimeButton" imageMso="TableInsertDialog" label="セルに時間を代入" keytip="A"
                    supertip="アクティブ セルに計測した時間を代入します。" onAction="リボンの君とストップウォッチ.xlam!onAction" />
            <checkBox id="PaintLabelButton" label="時間の表示を更新する" keytip="P"
                      supertip="チェックを外すと停止するまで時間の表示を更新しません(システムに負荷を掛けません)"
                      getEnabled="リボンの君とストップウォッチ.xlam!getEnabled"
                      onAction="リボンの君とストップウォッチ.xlam!checkBox_onAction"
                      getPressed="リボンの君とストップウォッチ.xlam!getPressed" />
          </box>
          <dialogBoxLauncher>
            <button id="AboutboxButton" imageMso="Info" screentip="バージョン情報" keytip="V" supertip="バージョン情報、著作権を表示します。"
                    onAction="リボンの君とストップウォッチ.xlam!onAction" />
          </dialogBoxLauncher>
        </group>
        
        <group id="Group2" label="数値" keytip="N">
          <box id="Box3" boxStyle="vertical">
            <comboBox idMso="NumberFormatGallery" sizeString="WWWWWWWW" />
            <box id="Box4" boxStyle="horizontal">
              <button idMso="DecimalsIncrease" />
              <button idMso="DecimalsDecrease" />
            </box>
            <button id="TimeFormatButton" imageMso="StartAfterPrevious" label="時刻の表示形式に変換" keytip="M"
                    supertip="セルの値を86,400で割って時刻の表示形式に変換します。(表示形式はhh:mm:ss.000)"
                    getEnabled="リボンの君とストップウォッチ.xlam!getEnabled" onAction="リボンの君とストップウォッチ.xlam!onAction" />
          </box>
          <dialogBoxLauncher>
            <button idMso="FormatCellsNumberDialog" />
          </dialogBoxLauncher>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

RibbonModule
Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
  Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
  Private TimerID As LongPtr
#Else
  Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
  Private TimerID As Long
#End If

Private rbRibbon As IRibbonUI ' リボン
Private rbLabel As String ' 時間のラベル
Private rbPaintLabel As Boolean ' 時間のラベルの描画を更新するか
Private myStopwatch As clsStopwatch ' ストップウォッチ

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set myStopwatch = New clsStopwatch
  rbLabel = Format(0, "0.00")
  rbPaintLabel = True
  Set rbRibbon = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbon.Invalidate ' リボンの表示を更新する
End Sub

Sub onAction(control As IRibbonControl) ' ボタンの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "StartButton" ' 開始
      myStopwatch.Start
      rbRibbon.InvalidateControl "StartButton"
      rbRibbon.InvalidateControl "StopButton"
      rbRibbon.InvalidateControl "ResetButton"
      rbRibbon.InvalidateControl "PaintLabelButton"
      rbRibbon.InvalidateControl "TimeFormatButton"
      If rbPaintLabel Then TimerID = SetTimer(0&, 0&, 100&, AddressOf OnTime_Proc)
    Case "StopButton" ' 停止
      If rbPaintLabel Then KillTimer 0&, TimerID
      myStopwatch.Stop_
      rbLabel = Format(myStopwatch.MicroSecond, "0.00")
      rbRibbon.InvalidateControl "labelControl1"
      rbRibbon.InvalidateControl "StartButton"
      rbRibbon.InvalidateControl "StopButton"
      rbRibbon.InvalidateControl "ResetButton"
      rbRibbon.InvalidateControl "PaintLabelButton"
      rbRibbon.InvalidateControl "TimeFormatButton"
    Case "ResetButton" ' リセット
      myStopwatch.Reset
      rbLabel = Format(0, "0.00")
      rbRibbon.InvalidateControl "labelControl1"
    Case "InsertTimeButton" ' セルに時刻を代入
      If ActiveCell Is Nothing Then Exit Sub
      ActiveCell.NumberFormatLocal = "0.00_ "
      ActiveCell.Value = myStopwatch.MicroSecond
      ActiveCell.Offset(1, 0).Select
    Case "TimeFormatButton" ' 時刻の表示形式に変換
      If ActiveCell Is Nothing Then Exit Sub
      Application.ScreenUpdating = False ' 画面の描画を更新しない
      Dim r As Range
      
      For Each r In ActiveWindow.RangeSelection
        r.NumberFormatLocal = "hh:mm:ss.000"
        If IsNumeric(r.Value) Then r.Value = r.Value / 86400
      Next
      Application.ScreenUpdating = True ' 画面の描画を更新する
    Case "AboutboxButton"
      MsgBox Prompt:=ThisWorkbook.Name & vbNewLine & vbNewLine & "Version 1.0.0.0" & vbNewLine & vbNewLine & "Copyright (C) 2019 陶山 栄一", Buttons:=vbInformation, Title:="情報"
    Case Else
'      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical, Title:="エラー"
  End Select
  
  Exit Sub
'------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Application.ScreenUpdating = True ' 画面の描画を更新する
'  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical, Title:="エラー"
End Sub

Sub OnTime_Proc() ' 割り込み処理
  rbLabel = Format(myStopwatch.MicroSecond, "0.00")
  rbRibbon.InvalidateControl "labelControl1" ' 計測時間を描画する
End Sub

Sub getLabel(control As IRibbonControl, ByRef returnedVal) ' ラベルを設定する
  returnedVal = rbLabel
End Sub

Sub getEnabled(control As IRibbonControl, ByRef returnedVal) ' ボタンの有効・無効を設定する
  Select Case control.ID
    Case "StartButton", "ResetButton", "PaintLabelButton", "TimeFormatButton"
      returnedVal = Not myStopwatch.IsRun
    Case "StopButton"
      returnedVal = myStopwatch.IsRun
  End Select
End Sub

Sub getPressed(control As IRibbonControl, ByRef returnedVal) ' チェックボックスにチェックを設定する
  returnedVal = rbPaintLabel
End Sub

Sub checkBox_onAction(control As IRibbonControl, pressed As Boolean) ' チェックボックスのクリック処理
  rbPaintLabel = pressed
End Sub

Sub Auto_Close() ' 終了時に実行
  On Error Resume Next
  If rbPaintLabel And myStopwatch.IsRun Then KillTimer 0&, TimerID
End Sub
このページの上

clsStopwatch
Option Explicit

#If Win64 Then
  Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LongLong) As Long
  Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LongLong) As Long
  Private Frequency As LongLong ' 周波数(1秒間の数)
  Private PerformanceCount As LongLong ' カウント数
#Else
  Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Double) As Long
  Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Double) As Long
  Private Frequency As Double ' 周波数(1秒間の数)
  Private PerformanceCount As Double ' カウント数
#End If

Private StartTime As Double ' 開始時刻
Private EndTime As Double ' 終了時刻
Private m_MicroSecond As Double ' マイクロ秒
Private m_IsRun As Boolean ' 計測中か

Property Get IsRun() As Boolean ' 計測中か?
  IsRun = m_IsRun
End Property
Property Let IsRun(NewValue As Boolean)
  m_IsRun = NewValue
End Property

Property Get MicroSecond() As Double ' 計測した時間(マイクロ秒)
  If IsRun Then
    EndTime = GetMicroSecond()
    m_MicroSecond = m_MicroSecond + (EndTime - StartTime)
    StartTime = EndTime
  End If
  
  MicroSecond = m_MicroSecond
  End Property
  
Private Function GetMicroSecond() As Double ' 時刻を取得する
  Call QueryPerformanceCounter(PerformanceCount)
  GetMicroSecond = PerformanceCount / Frequency ' 計測した時刻(マイクロ秒)
End Function
  
Private Sub Class_Initialize() ' 初期処理
  IsRun = False
  Call Reset
  Call QueryPerformanceFrequency(Frequency) ' 高分解能パフォーマンスカウンタの周波数(1秒間の数)
End Sub

Public Sub Start() ' 計測を開始
  IsRun = True
  StartTime = GetMicroSecond()
End Sub

Public Sub Stop_() '計測を停止する
  IsRun = False
  EndTime = GetMicroSecond()
  m_MicroSecond = m_MicroSecond + (EndTime - StartTime)
End Sub

Public Sub Reset() ' 計測時間をリセットする
  StartTime = 0
  EndTime = 0
  m_MicroSecond = 0#
End Sub

Public Sub DebugPrint() ' 計測時間をイミディエイトウィンドウに出力する
  Debug.Print MicroSecond
End Sub
このページの上