これは自分の備忘録であり、私が思い出すための記事なのでご了承のほど。
５分くらい時間がかかるマクロがあり、固まっていないか心配になると上司から指摘があり、進捗バーを作ろうとする。
VBAのプログラム実行中はカーソルがサークル形になり、グルグル回っているが、グルグル回ったまま止まっているのかもしれないし、確かに不安かもしれない。
とりあえずユーザーフォームで作って見る。こんな感じ。
部品は、
- 実行中です・・しばらくお待ちください」のラベル
- 正方形のラベルにborderを付けたものを１０個
これだけ。border付ラベルのオブジェクト名はLabel1～Label10にしておく。
このLabel1～Label10の背景色を進捗の過程で１つ１つ変えていく。原理はそれだけです。
ユーザーフォームの名前はUserForm1にしておく。
メインロジックはこんな感じ。このソースそのままでは動きません。下で解説してるのでご参考までに。
Sub メイン() '①進捗状況フォームをモードレスで表示 UserForm1.Show 0 '②いきなりラベルの色を１つ青くする UserForm1.Label1.BackColor = vbBlue '③ラベルの色を変えたことを画面に反映させる DoEvents '④長い処理時間のため画面遷移をオフにする Application.ScreenUpdating = False '⑤ループ処理（長い処理時間）▼ 'ブレークポイントなら If breakpoint = True Then 'ProgressBarを１つ青くする Call Progress_add End If 'ループ処理▲ '⑥ProgressBarを全て青くする Call Progress_all '⑦画面遷移をオン Application.ScreenUpdating = True '⑧ユーザ―フォームを閉じる Unload UserForm1 End Sub
- 今回やりたいのは表示をさせた裏でプログラムを走らせることだが、引数に0を指定してモードレスにしておかなければ、処理が先に進まない。
- これはユーザービリティの話だと思うけど、最初に青くさせた方が安心感があると思って、とりあえず初っ端Label1を青くしている。
- DoEventsをしないと2の変更が画面上変わらないので、これをしておく。画面更新の意味ですね。
- これは今回必ずしも必要ないけど、長時間のマクロには画面遷移は不要。オフっておくことでだいぶ速度が速くなる。
- ここが実際の処理にあたる。今回は仮なので適当。
- ProgressBarの数を10個にしているとBreakPointが9個無いと全部青くならないので、最後にすべて青くする処理を施す。
- 画面遷移を元に戻しておく。
- プログラム終了前にユーザーフォームを閉じる。
これがブレークポイントで呼び出すサブルーチンのコード。
'①パブリック変数定義 Public Progress_cnt As Integer Sub Progress_add() 'ラベル名変数定義 Dim Label_name As String '②エラー無視 On Error Resume Next '③次のラベル名を取得する Label_name = "Label" & Progress_cnt + 2 '一時的に画面遷移オン Application.ScreenUpdating = True '④ラベルを青くする UserForm1.Controls(Label_name).BackColor = vbBlue '⑤カウンター足しこみ Progress_cnt = Progress_cnt + 1 '表示更新 DoEvents '画面遷移オフに戻す Application.ScreenUpdating = False End Sub
- このコードは別から呼び出されるのでパブリック変数として次に青くするラベルの数を保存しておく
- ブレークポイントがLabel10を超えてしまうかもしれないので一応エラーを無視しておく
- Progress_cntは0からスタートする。メインでLabel1を青くしたから、+2をしてLabel2からスタート。
- UserForm1.Controls(引数）でLabel1～10を指定できる。これで青くする。
- カウンターを足しこむ
最後にすべてのラベルを青くするコード
'①スリープ処理の決まり文句
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Progress_all()
'ラベル名
Dim Label_name As String
Dim Sleep_Time As Integer
'エラー無視
On Error Resume Next
'一時的に画面遷移オン
Application.ScreenUpdating = True
'②スリープ時間を5ミリ秒に設定
Sleep_Time = 500
'③ラベル１０個分回す
For i = Progress_cnt To 10
'次のラベルを取得する
Label_name = "Label" & i
'ラベルを青くする
UserForm1.Controls(Label_name).BackColor = vbBlue
'表示更新
DoEvents
'④スリープ
If Sleep_Time > 1 Then
Sleep Sleep_Time
End If
'⑤スリープタイムを減らして加速する
Sleep_Time = Sleep_Time - 70
Next i
'画面遷移オフに戻す
Application.ScreenUpdating = False
End Sub
- スリープを使えるようにする。プログラムの処理は一瞬なので少し間をあけてラベルの色を変えないと視認できない。
- １秒だと長いので0.5ミリ秒にする
- Labalは10個あるので、現在のカウントから10まで回す。
- スリープをする。ただし⑤の処理でSleep_Timeが̠̠マイナスになっても大丈夫なように１以上のときに実行する
- 毎回0.5秒ずつ増えていくと単調なので、徐々に減らして加速する。
こんな感じ。変に固まってUserFormが後ろに隠れてしまうことがたまにあるので、万能ではないかもしれない。
ただユーザを不安にさせない時間稼ぎくらいにはなるだろう。
あとVBAのコントロールにはProgressBarがあったらしいが、最近無くなったそうです。もしかしたら見つけられないだけかも。
コメント