長い時間を要する処理をしている間は、マウスカーソルを［砂時計］にしたり、進行の程度(現在どこまで進んでいるのかや、あとどれくらいかかるのか)を表示すると、ユーザに親切です。
そんな進行表示の方法を、三種類紹介します。
１．ステータスバー その1
Excelにはそんな表示をするためのStatusBarというおApplication.StatusBar プロパティがあります。
Application.StatusBar プロパティの仕様は、VBAのヘルプをみてください。
Option Explicit
Dim oldstatusbar As Variant
Public abortFlag As Boolean
Public Sub setStatusBar(msg As Variant)
'ステータスバー表示
With Application
oldstatusbar = .DisplayStatusBar
.DisplayStatusBar = True
.StatusBar = msg
End With
End Sub
Public Sub msgStatusBar(msg As Variant)
With Application
.StatusBar = msg
End With
End Sub
Public Sub resetStatusBar()
'ステータスバー復帰
With Application
.StatusBar = False
.DisplayStatusBar = oldstatusbar
End With
End Sub
進行表示のテストプログラムです。
Public Sub progressbar11()
'StatusBarで進行表示その1
Dim idx As Long
Const idxmax As Long = 20
Dim tm As Variant
'Excelウィンドウの左下にあるステータスバーを初期化する
Call setStatusBar("しばらくお待ちください‥")
For idx = 0 To idxmax
'ステータスバーにメッセージを表示する
Call msgStatusBar("しばらくお待ちください‥" & idx & "/" & idxmax)
'**********
' 本来の繰り返し処理がここに入る
'**********
'**********
' 本来の繰り返し処理の代わり
tm = Timer() 'システムのタイマー
Do Until Timer() - tm > 1
DoEvents '1 秒経過するまで待つ
Loop
'**********
Next idx
'ステータスバーをリセットする
Call resetStatusBar
End Sub
以下、使用例です。
どうですか？とても簡単に使えますよね。動作の負荷もあまりかからないし、手軽に使えて便利です。 その反面、なんだか物足りなさも感じます。
２．ステータスバー その2
今度は、同じステータスバーですが、少しグラフィカルっぼくしてみます。
Public Function initStrBar(barLength As Long) As Variant
initStrBar = String(barLength, "□")
End Function
Public Function setStrBar(crntValue As Long, maxValue As Long, barLength As Long) As Variant
setStrBar = String(CInt(barLength * crntValue / maxValue), "■") _
& String(barLength - CInt(barLength * crntValue / maxValue), "□")
End Function
Public Sub progressbar12()
'StatusBarで進行表示 その2
Dim idx As Long
Const idxmax As Long = 20
Dim tm As Variant
Const prgrsmax As Long = 30
'Excelウィンドウの左下にあるステータスバーを初期化する
Call setStatusBar(initStrBar(prgrsmax))
For idx = 0 To idxmax
'ステータスバーにバーを表示する
Call msgStatusBar(setStrBar(idx, idxmax, prgrsmax))
'**********
' 本来の繰り返し処理がここに入る
'**********
'**********
' 本来の繰り返し処理の代わり
tm = Timer() 'システムのタイマー
Do Until Timer() - tm > 1
DoEvents '1 秒経過するまで待つ
Loop
'**********
Next idx
'ステータスバーをリセットする
Call resetStatusBar
End Sub
実行結果は次のとおり。
少しはグラフィカルになったでしようか？
まだまだですかね？？
３． フォームを使ったプログレスバー
では自前のプログレスバーです。
以下のように、まず、ユーザフォームを挿入します。
lblBackをlblFrontのうしろに、図のように配置します。ここではコントロールの大きさは橙でかまいません。
ユーザフォームのプログラムです。
Option Explicit
Public widthmax As Long
Private Sub cmdAbort_Click()
abortFlag = True
End Sub
Private Sub UserForm_Initialize()
With txtMsg
.BackColor = &H8000000F
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H8000000F
.Text = ""
End With
With txtProgressbar
.BackColor = &H8000000F
.BorderStyle = fmBorderStyleSingle
.BorderColor = &H8000000F
.Text = ""
End With
With lblBack
.BackColor = &H8000000F
widthmax = .Width - 2 * 1
End With
With lblFront 'サイズを調節します
.Left = lblBack.Left + 1
.Top = lblBack.Top + 2
.Height = lblBack.Height - 2 * 2
.Width = 0
.BackColor = &H8000&
.Caption = ""
.TextAlign = fmTextAlignCenter
End With
End Sub
Private Sub UserForm_Terminate()
abortFlag = True
End Sub
次に進行表示のプログラム。
Public Sub progressbar21()
'ユーザフォームで進行表示
Dim idx As Long
Const idxmax As Long = 20
Dim tm As Variant
Dim wdmax As Long
With frmProgress
'フォームを初期化後表示する
wdmax = .widthmax 'フォームからラベルの表示幅を取得
.txtMsg.Text = "しばらくお待ちください‥"
'フォームを表示
' → modelessなので表示したまま他の(show 以下の)処理を実行可能
' ただし、Modalで表示しているフォームから、さらにmodelessで
' フォームを表示することはできない
.Show vbModeless
abortFlag = False '中止フラグを初期化
For idx = 0 To idxmax
If abortFlag Then
'中止ボタンが押されたら、中止
Exit For
End If
'プログレスバーを表示
With .lblFront
.Width = wdmax * idx / idxmax
End With
With .txtProgressbar
.Text = idx & "/" & idxmax
End With
'**********
' 本来の繰り返し処理がここに入る
'**********
'**********
' 本来の繰り返し処理の代わり
tm = Timer() 'システムのタイマー
Do Until Timer() - tm > 1
DoEvents '1 秒経過するまで待つ
Loop
'**********
Next idx
End With
'フォームを削除する
Unload frmProgress
Set frmProgress = Nothing
End Sub
実行結果は右図のとおりです。
