<概要>
今回は、進行状況をステータスバーに表示する汎用プロシージャを紹介します。
作成したプログラムの進行状況をユーザーに知らせるための処理は、時間を要する処理において実装するのはマナーのようなものです。
進行状況、いわゆるプログレスバーは開発者によっていろいろ個性がでるので面白いところですが、私の場合はステータスバーを利用して最小限の情報とコードで実装しています。
<用途>
・時間を要する処理の進行状況をお知らせする。
<プロシージャ紹介>
Public Sub ShowStatusBarProgress(Value As Long, MaxValue As Long, [Divide As Long = 1], [Message As String = ""])
名前：ShowStatusBarProgress/Subプロシージャ
説明：進行状況をステータスバーに表示する
引数
Value ・・・現在個数
MaxValue ・・・全体個数
[Divide] ・・・分割幅(Valueが何回に1回のときにスターテスバーを更新するか)/省略なら1で毎回更新
[Message]・・・表示メッセージ
<実行例>
次のようなコードを記述します。
実行すると左下のステータスバーには次のような表示がされます。
この汎用プロシージャを使用する上での注意点ですが、ループ数が多いときは分割数「Divide」をしっかり指定することです。
「スターテスバーに文字列を表示する」処理自体に処理時間を要するため、デフォルト値で「Divide=1」とするとループ毎にスターテスバーが更新されて余計に処理に時間がかかってしまいます。
ちなみに、今回のように進行状況をお知らせせずに実行するのが一番処理時間が短くてすみます。その代わり「どのくらい進んでいるか」が分からなくなります。それぞれ長所短所ですね。
<コード>
Public Sub ShowStatusBarProgress(ByRef Value As Long, _
ByRef MaxValue As Long, _
Optional ByRef Divide As Long = 1, _
Optional ByRef Message As String = "")
'進行状況をスターテスバーに表示する
'20220204
'20220421 経過時間、終了予定時刻なども表示可能に
'20220530 先頭にメッセージを表示可能に
'20221217 分割幅(Divide)を指定可能に
'20230219 イミディエイトウィンドウにも表示
'https://www.softex-celware.com/post/showstatusbarprogress
'引数
'Value ・・・現在個数
'MaxValue ・・・全体個数
'[Divide] ・・・分割幅(Valueが何回に1回のときにスターテスバーを更新するか)/省略なら1で毎回更新
'[Message]・・・先頭メッセージ
Static StartTime As Double
If StartTime = 0 Then
StartTime = Now()
End If
If Value Mod Divide <> 0 Then 'Divide=10の場合、Value=1,11,21...のときのみ処理
If Value <> MaxValue Then 'Value=MaxValueのとき(最後の位置)は処理する
Exit Sub '処理しない
End If
End If
Dim Per As Double: Per = Value / MaxValue '作業完了率
Dim ElapsedTime As Double: ElapsedTime = Now() - StartTime '経過時間
Dim TimePerSingle As Double: TimePerSingle = ElapsedTime / Value '1件当たり作業時間
Dim RemainTime As Double: RemainTime = (MaxValue - Value) * TimePerSingle '残り予定時間
Dim FinishTime As Double: FinishTime = RemainTime + Now() '終了予定時刻
Dim strMessage As String: strMessage = Format(Per, "0.0%完了") & ", " & _
Value & "/" & MaxValue & ", " & _
"残り時間：" & Format(RemainTime, "h時間mm分ss秒") & ", " & _
"完了予定時刻：" & Format(FinishTime, "h時mm分")
' strMessage = Message & " " & strMessage
strMessage = strMessage & " " & Message
Application.StatusBar = strMessage
Debug.Print strMessage 'イミディエイトウィンドウにも表示'20230219
DoEvents 'スターテスバー表示で固まらないようにするための処理
If Value = MaxValue Then StartTime = 0
End Sub
留言