ExcelのVBAでプログレスバーを作ったが、毎回コードに埋め込むのが面倒なのでクラスで作ってみた

Excelでの処理中は、ステータスバーでプログレスバーを表現するのが常套手段らしいのだが、毎回毎回コードに埋め込むのが面倒になってきたところ、「これってクラス向きでねぇ？」という発想に至りクラスで作ってみた。

## 使い方

`Progress.cls` クラスライブラリをExcelで使用したいブックにインポートする。

```VB: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
```

標準モジュールなどから以下のようにクラスとして使用。

```VB
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を代入する意味**がわかったような気がする。)

```VB
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を公開メソッドに変更。