Excelでの処理中は、ステータスバーでプログレスバーを表現するのが常套手段らしいのだが、毎回毎回コードに埋め込むのが面倒になってきたところ、「これってクラス向きでねぇ？」という発想に至りクラスで作ってみた。
使い方
Progress.cls クラスライブラリをExcelで使用したいブックにインポートする。
Progress.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Progress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Progress Barのクラスによる実装
'
' Author: Katsuya Nagai <katsuya.1128@gmail.com>
'
Option Explicit
Private myProgress As Long ' 現在のProgress
Private myProgressMax As Long ' Progressの最大値
Private myProgressCount As Long ' Progress Barの長さ
Private myPreMessage As String ' Progress Bar前のメッセージ
Private myPostMessage As String ' Progress Bar後のメッセージ
Private myDoneChar As String ' 完了の文字
Private myYetChar As String ' 未了の文字
Private myDisplayStatusBar As Boolean ' ステータスバー状態復元用
Private myStatusBar As Variant ' ステータスバー内容復元用
Private myScreenUpdating As Boolean ' 画面の更新状態復元用
Private Sub ShowProgressBar()
' プログレスバーを素描する。
Dim done As Long, yet As Long
' 現在のプログレスが最大最小をはずれないように補正
If myProgress < 0 Then
myProgress = 0
End If
If myProgress > myProgressMax Then
myProgress = myProgressMax
End If
' 処理済み
done = myProgressCount * myProgress / myProgressMax
' 未処理
yet = myProgressCount - done
Application.StatusBar = myPreMessage & _
String(done, myDoneChar) & String(yet, myYetChar) & _
myPostMessage
End Sub
Private Sub Class_Initialize()
' コンストラクタ
myProgressMax = 100 ' Progress Barのデフォルトの最大値
myProgress = 0 ' 現在のProgress
myProgressCount = 20 ' Progress Barのデフォルトの長さ
myPreMessage = "処理中... " ' Progress Bar前のデフォルトメッセージ
myPostMessage = "" ' Progress Bar後のデフォルトメッセージ
myDoneChar = "■" ' 完了の文字
myYetChar = "□" ' 未了の文字
' 画面更新状態保全
myScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
' ステータスバー保全
myDisplayStatusBar = Application.DisplayStatusBar
myStatusBar = Application.StatusBar
' ステータスバー表示
Application.DisplayStatusBar = True
' ShowProgressBar
End Sub
Private Sub Class_Terminate()
' デストラクタ
' 画面更新状態復元
Application.ScreenUpdating = myScreenUpdating
' ステータスバー復元
RestoreStatusBar
Application.DisplayStatusBar = myDisplayStatusBar
End Sub
Public Sub Increment(Optional Incremental As Long = 1)
' 直接代入する代わりにインクリメント
myProgress = myProgress + Incremental
ShowProgressBar
End Sub
Property Let PreMessage(msg As String)
' プログレスバー前のメッセージの設定
myPreMessage = msg
' ShowProgressBar
End Property
Property Get PreMessage() As String
' プログレスバー前のメッセージの取得
PreMessage = myPreMessage
End Property
Property Let PostMessage(msg As String)
' プログレスバー後のメッセージの設定
myPostMessage = msg
' ShowProgressBar
End Property
Property Get PostMessage() As String
' プログレスバー後のメッセージの取得
PostMessage = myPostMessage
End Property
Property Let ProgressCount(pcount As Long)
' プログレスバーの長さ設定
If pcount < 1 Then
pcount = 1
End If
myProgressCount = pcount
' ShowProgressBar
End Property
Property Get ProgressCount() As Long
' プログレスバーの長さ取得
ProgressCount = myProgressCount
End Property
Property Let ProgressMax(pmax As Long)
' プログレスの最大値設定
If pmax < 1 Then
pmax = 1
End If
myProgressMax = pmax
' ShowProgressBar
End Property
Property Get ProgressMax() As Long
' プログレスの最大値取得
ProgressMax = myProgressMax
End Property
Property Let Progress(p As Long)
' 現在のプログレス設定
myProgress = p
ShowProgressBar
End Property
Property Get Progress() As Long
' 現在のプログレス取得
Progress = myProgress
End Property
Property Let DoneChar(c As String)
' 完了の文字の設定
myDoneChar = c
End Property
Property Get DoneChar() As String
' 現在の完了の文字の取得
DoneChar = myDoneChar
End Property
Property Let YetChar(c As String)
' 完了の文字の設定
myYetChar = c
End Property
Property Get YetChar() As String
' 現在の完了の文字の取得
YetChar = myYetChar
End Property
Sub ScreenUpdate(Optional Updating As Boolean = True)
' 画面更新する
' myScreenUpdating = Updating
Application.ScreenUpdating = Updating
End Sub
Sub ResetStatusBar()
' ステータスバーのリセット
Application.StatusBar = False
End Sub
Private Sub RestoreStatusBar()
' ステータスバーの復元
' Variant型だからなのかそのまま代入してもFALSEという文字列になってしまう。Why?
If myStatusBar = False Then
Application.StatusBar = False
Else
Application.StatusBar = myStatusBar
End If
End Sub
標準モジュールなどから以下のようにクラスとして使用。
Option Explicit
Private Const OneDayms = 86400000 ' 24h * 60m * 60s * 1000ms
Sub Test()
Const MAX = 20
Dim p As Progress
Set p = New Progress
Dim i As Long, j As Long, r As Long, c As Long
p.ProgressMax = MAX * MAX
For i = 1 To MAX
For j = 1 To MAX
' p.Progress = i * MAX + j
p.Increment
Cells(i, j).Value = i * j
' 10ms 待つ
Application.Wait [Now()] + 10 / OneDayms
Next j
Next i
MsgBox "Done"
End Sub
プログレスバーを消してからメッセージボックスを出したい/画面更新を反映したい場合にはNothingを代入してオブジェクトを開放しましょう。
(生まれて初めてVBAでオブジェクトにNothingを代入する意味がわかったような気がする。)
Option Explicit
Private Const OneDayms = 86400000 ' 24h * 60m * 60s * 1000ms
Sub Test()
Const MAX = 20
Dim p As Progress
Set p = New Progress
Dim i As Long, j As Long, r As Long, c As Long
p.ProgressMax = MAX * MAX
For i = 1 To MAX
For j = 1 To MAX
p.Progress = i * MAX + j
p.Increment
Cells(i, j).Value = i * j
' 10ms 待つ
Application.Wait [Now()] + 10 / OneDayms
Next j
Next i
' 開放の儀
Set p = Nothing
' とりあえず左上にカーソルを持って行く。
Range("A1").Select
MsgBox "Done"
End Sub
メソッド
Sub Increment
ProgressをIncremental分増加させる。
| 引数 | 型 | 省略時 |
|---|---|---|
| Incremental:=増分 | Long | 1 |
Sub ScreenUpdate
画面更新を変更する。
クラス解放後はクラス生成時の状態に戻る。
| 引数 | 型 | 省略時 |
|---|---|---|
| Updating:=更新 | Boolean | True |
Sub ResetStatusBar
ステータスバーのリセット。
クラス開放時には元の値に戻す。
プロパティ
| 名称 | 型 | デフォルト | 働き |
|---|---|---|---|
| Progress | Long | 0 | 現在の Progress |
| ProgressMax | Long | 100 | プログレスの最大値 |
| ProgressCount | Long | 20 | プログレスバーの長さ |
| PreMessage | String | "処理中... " | プログレスバー前の文字列を指定 |
| PostMessage | String | "" | プログレスバー後の文字列を指定 |
| DoneChar | String | "■" | 完了の文字 |
| YetChar | String | "□" | 未了の文字 |
その他
クラスの性格上、大きなお世話で Application.ScreenUpdating を False にしてしまいますが、Excelが頑張っている様子を見たければ、インスタンス生成後にScreenUpdateメソッドを呼び出してください。
2019年7月31日追記
- メソッドにIncrementを追加。
2019年8月2日追記
- メソッドにScreenUpdateを追加、ResetStatusBarを公開メソッドに変更。