Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active November 30, 2024 04:31
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save furyutei/6cd8538cd306f9df346b87276c7ec05f to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save furyutei/6cd8538cd306f9df346b87276c7ec05f to your computer and use it in GitHub Desktop.
Download ZIP
[Excel][VBA] Application.OnTimeによる割り込みが可能なWaitプロシージャを試作
Raw
0.README.md

[Excel][VBA] Application.OnTimeによる割り込みが可能なWaitプロシージャを試作

待ち時間中でも、画面更新、キー入力やマウス操作、Application.OnTimeによるプロシージャの実行などを阻害しないようなWaitプロシージャ(WaitEx)を試作。

Public Sub WaitEx(ByVal WaitMilliSeconds As Long)

パラメーター
---
[in] WaitMilliSeconds
  待ち時間（ミリ秒）。
  ※INFINITEで無限待ち

戻り値
---
なし

概要

一定時間処理を待つ(停止する)手段としてはApplication.WaitやSleep(Win32API)があるけれども、これらは指定した期間が経過するまではその間のウィンドウメッセージ（イベント）が処理されない問題がある。
WaitやSleepが実行中の場合には、例えば画面更新はされなくなり、Escキー等による中断も難しく、Application.OnTimeによって特定のタイミングでプロシージャを呼び出そうとしても、これらが終了するまでは待たされてしまう。

これを回避するための常套手段としては、指定時間になるまでループ内で短い間隔でWaitやSleepを繰り返し実行し、その都度DoEventsを呼び出すことによりイベント処理が可能なタイミングを挟み込む、というものがある（もしくは単にDoEventsを指定時間までひたすら繰り返したりする）が、メッセージ(イベント)の有無に関わらずDoEventsが呼び出されるために処理が重くなったりする等の問題がある。

そこで、WaitExの内部処理では、WaitやSleepの代わりとして、Win32APIのMsgWaitForMultipleObjectsを用いた（なお、MsgWaitForMultipleObjectsExでも同様のことは可能）。
これらは、メッセージ(イベント)があるタイミングかもしくは指定時間経過で終了するといった指定が可能なため、DoEventsの呼び出しはそのタイミングだけとなり、処理効率がよくなることが期待できる。

参考

備忘

Application.Evaluateを使っている関係で、Excel VBAでしか動かない。
↓
メインモジュール(Mod_WaitEx)中ではEvaluateを使わないようにしたので、WaitExプロシージャについてはExcel VBA以外のVBAでもおそらく利用可能。

ただし、例えばWordのApplication.OnTimeの仕様との違いから（例えば引数付きプロシージャ呼び出しはできない・一度に設定できるタイマは1個のみ）、テストモジュール(Mod_TestWaitEx)の方は正しく動かない。
↓
自前のモジュール（Mod_Callback）を用いたテストモジュール(Mod_TestCallback)の方であれば、Wordでも動いた。

Raw
Mod_TestCallback.VBA
' 別途[Mod_Callback](https://gist.github.com/furyutei/a571a70d41773bc00b4a3ab2be997985#file-mod_callback-vba)が必要
Option Explicit
Sub TestCallback()
OnTimeEx NowEx() + 1# / 86400#, "OnTimeProc2", "1秒後"
OnTimeEx NowEx() + 2# / 86400#, "OnTimeProc2", "2秒後"
OnTimeEx NowEx() + 3# / 86400#, "OnTimeProc2", "3秒後"
Dim StartTime As Double: StartTime = NowEx(): Debug.Print "[WaitEx開始]", FormatTime(StartTime)
WaitEx 5000 ' メッセージ受付可能な状態で5秒待つ
Dim EndTime As Double: EndTime = NowEx(): Debug.Print "[WaitEx終了]", FormatTime(EndTime)
Debug.Print "※経過時間: " & Format((EndTime - StartTime) * 86400#, "0.00") & "秒"
End Sub
Sub OnTimeProc2(ByVal Message As String)
Debug.Print "OnTime(" & Message & ")", FormatTime(NowEx())
End Sub
Private Function FormatTime(ByVal TargetTime As Double) As String
' FormatTime = Evaluate("TEXT(" & TargetTime & ",""yyyy/mm/dd hh:mm:ss.00"")")
FormatTime = Format(Fix(TargetTime * 86400#) / 86400#, "yyyy/mm/dd hh:nn:ss") & Right(Format((TargetTime - Fix(TargetTime)) * 86400#, "0.00"), 3)
End Function
Private Function NowEx() As Double
NowEx = CDbl(Date) + CDbl(Timer) / 86400#
End Function
Raw
Mod_TestWaitEx.vba
Option Explicit
Sub TestWaitEx()
Application.OnTime NowEx() + 1# / 86400#, "'OnTimeProc ""1秒後""'"
Application.OnTime NowEx() + 2# / 86400#, "'OnTimeProc ""2秒後""'"
Application.OnTime NowEx() + 3# / 86400#, "'OnTimeProc ""3秒後""'"
Dim StartTime As Double: StartTime = NowEx(): Debug.Print "[WaitEx開始]", FormatTime(StartTime)
WaitEx 5000 ' メッセージ受付可能な状態で5秒待つ
Dim EndTime As Double: EndTime = NowEx(): Debug.Print "[WaitEx終了]", FormatTime(EndTime)
Debug.Print "※経過時間: " & Format((EndTime - StartTime) * 86400#, "0.00") & "秒"
End Sub
Sub OnTimeProc(ByVal Message As String)
Debug.Print "OnTime(" & Message & ")", FormatTime(NowEx())
End Sub
Private Function FormatTime(ByVal TargetTime As Double) As String
' FormatTime = Evaluate("TEXT(" & TargetTime & ",""yyyy/mm/dd hh:mm:ss.00"")")
FormatTime = Format(Fix(TargetTime * 86400#) / 86400#, "yyyy/mm/dd hh:nn:ss") & Right(Format((TargetTime - Fix(TargetTime)) * 86400#, "0.00"), 3)
End Function
Private Function NowEx() As Double
NowEx = CDbl(Date) + CDbl(Timer) / 86400#
End Function
Raw
Mod_WaitEx.vba
Option Explicit
Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32" ( _
ByVal nCount As Long, _
ByVal pHandles As LongPtr, _
ByVal fWaitAll As Boolean, _
ByVal dwMilliseconds As Long, _
ByVal dwWakeMask As Long _
) As Long
Private Enum QueueStatusConst
QS_KEY = &H1&
QS_MOUSEMOVE = &H2&
QS_MOUSEBUTTON = &H4&
QS_POSTMESSAGE = &H8&
QS_TIMER = &H10&
QS_PAINT = &H20&
QS_SENDMESSAGE = &H40&
QS_HOTKEY = &H80&
QS_ALLPOSTMESSAGE = &H100&
QS_RAWINPUT = &H400&
QS_TOUCH = &H800&
QS_POINTER = &H1000&
QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
QS_INPUT = (QS_MOUSE Or QS_KEY Or QS_RAWINPUT Or QS_TOUCH Or QS_POINTER)
QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
QS_ALLINPUT = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY Or QS_SENDMESSAGE)
End Enum
Private Enum WaitReturnValueConst
WAIT_OBJECT_0 = &H0&
WAIT_ABANDONED_0 = &H80&
WAIT_TIMEOUT = &H102& ' 258
WAIT_FAILED = &HFFFFFFFF
End Enum
Public Enum ModWaitExConst
INFINITE = -1&
End Enum
Public Sub WaitEx(ByVal WaitMilliSeconds As Long)
Dim StartTime As Double: StartTime = NowEx()
Dim RemainedMilliSeconds As Long: RemainedMilliSeconds = WaitMilliSeconds
Dim ReturnValue As Long
Do
ReturnValue = MsgWaitForMultipleObjects(0, 0, False, RemainedMilliSeconds, QS_ALLINPUT)
DoEvents
If ReturnValue = WAIT_TIMEOUT Then Exit Do
If WaitMilliSeconds <> INFINITE Then RemainedMilliSeconds = WaitMilliSeconds - CLng((NowEx() - StartTime) * 86400000#)
Loop While (0 < RemainedMilliSeconds Or WaitMilliSeconds = INFINITE)
End Sub
Private Function NowEx() As Double
NowEx = CDbl(Date) + CDbl(Timer) / 86400#
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment