ユーザーフォームにプログレス・バー
必要になると、ユーザーフォームの下端に飛び出して表示されるプログレス・バーを作成してみました。
下の左図は通常のユーザーフォームの状態、右図はプログレス・バーが表示されている状態です。
このユーザーフォームは、複数のスタッフのための予定表を作成するプログラムの一環なのですが、その内容はここでは全く関係ありません。フォーム左下端の「作成開始」ボタンをクリックすると、ここの設定では２０２５年の１月から１２月までの白紙の暦をワークシートに作成し、各自の入力に供するというもの。その暦の作成（行列の高さ・幅を調整したり、土日祝日に色をつけたり、といろいろと手間がかかるので）に少し時間がかかります。それで、暦を作成している間、その実行状況をプログレス・バーで表示することにしたものです。
終わると、プログレス・バーは引っ込みます。
ユーザーフォーム OptionForm の中の関連部分は、こうなっています。
CreateCalenderImage でマウスボタンが押されると、CreateCalender が呼ばれます。
ユーザーフォームでは、これだけ。
フォーム OptionForm
'----- 「作成開始」ボタン
Private Sub CreateCalenderImage_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Dim maxCount
CreateCalender Me, 1000
End Sub
呼ばれた CreateCalender は、作業の本体です。プログレス・バーを初期化し、所定の作業を行いながらステップごとにプログレス・バーを延ばして、最後にそれを閉じます。
標準モジュール CreateCalender()
'----- 待ち時間（ダミー） mSec
Private Const waitTime = 10
'----- 実際の実行マクロ
Public Sub CreateCalender(form, maxCount)
'プログレス・バーの表示と初期化
OpenProgressBar form, maxCount
'作業の本体を呼ぶ
actionLoop maxCount
'プログレス・バーを閉じる
CloseProgressBar
End Sub
'----- ここで、１ステップごとの作業を実施しながら
' プログレス・バーを一つずつ延ばす
Private Sub actionLoop(maxCount)
Dim index
For index = 1 To maxCount
'実際には、ここに１ステップの作業が書かれる
'ここでは、waitTime だけ待つ関数をいれてある
Application.Wait [now()] + waitTime / 86400000
'ここでプログレス・バーの長さを index にセット
StepProgressBar index
DoEvents
Next
End Sub
CreateCalender から呼ぶ ProgressBar を操作する関数は以下。
外枠の frame と中の棒にあたる bar をそれぞれ Label で作成し、bar の幅を変化させていきます。
使いかたは、上記を参照。
最初の OpenProgressBar に引数としてユーザーフォームのオブジェクトへの参照と最大値を与えて、あとは StepProgressBar にステップ数を与えていくだけです。
ただし、中で使用するパラメーターはここだけのものですので、呼び出しが重複したりすると、それまでのプログレス・バーが破棄されてしまいます。その後、どうなるかわかりません。
汎用のプログレス・バーを用意するなら、これをそっくりクラスにして、作業の本体ではクラスのインスタンスを生成し、そのメソッドを呼ぶようにしたほうがよいでしょう。そうすれば、複数の同時進行の作業のプログレス・バーを表示することができます。
標準モジュール OpenProgressBar(), CloseProgressBar(), StepProgressBar()
'表示するフォームとそのサイズ
Private parentForm
Private parentWidth
Private parentHeight
Private overAllHeight
'フォーム上に表示するバー
Private bar
Private frame
'バーの名前
Private Const barName = "progressBar"
Private Const frameName = "progressFrame"
'ProgressBar のサイズ
Private Const frameHeight = 8
Private Const frameMargin = 3
Private Const barPadding = 1.5
'最大値
Private maxCount
Private maxWidth
'===== ProgressBar の表示
'----- Open
'表示するフォームと最大値を指定して実行
Public Sub OpenProgressBar(form, max)
Dim x, y, w, h
Set parentForm = form
maxCount = max
With form
'有効な画面サイズと元の高さを計算
parentWidth = .width - 12
overAllHeight = .height
parentHeight = overAllHeight - 29.25
'高さを ProgressBar の分だけ拡張
.height = overAllHeight + frameHeight + frameMargin * 2
End With
'frame を描く
x = frameMargin
y = parentHeight + frameMargin
h = frameHeight
maxWidth = parentWidth - frameMargin * 2
Set frame = createLabel(frameName, x, y, maxWidth, h, fmBorderStyleSingle, vbBlack, fmBackStyleTransparent, 0)
'bar を描く
x = x + barPadding
y = y + barPadding
h = h - barPadding * 2
Set bar = createLabel(barName, x, y, 0, h, fmBorderStyleNone, 0, fmBackStyleOpaque, RGB(0, 128, 128))
'maxWidth を設定
maxWidth = maxWidth - barPadding * 2
End Sub
'frame / bar の label コントロールを描画する
Private Function createLabel(name, x, y, w, h, lStyle, lColor, bStyle, bColor)
Set createLabel = parentForm.Controls.Add("Forms.Label.1", name, True)
With createLabel
.top = y
.left = x
.height = h
.width = w
.BorderStyle = lStyle
.BorderColor = lColor
.BackStyle = bStyle
.BackColor = bColor
End With
End Function
'----- Close
'frame / bar のコントロールを削除してフォームの高さを元に戻す
Public Sub CloseProgressBar()
parentForm.Controls.Remove barName
parentForm.Controls.Remove frameName
parentForm.height = overAllHeight
End Sub
'----- Step
'bar の幅を steps に調整する
Public Sub StepProgressBar(steps)
bar.width = steps / maxCount * maxWidth
End Sub
プログレス・バーをワークシート上に作成する場合は、四角形の Shape を使って、いろんなテクスチュアのバーを描けたのですが、ユーザーフォームのコントロールの場合は Back にそういうプロパティが見当たらなかったので、扁平なものになり、ちょっと色気がなくなりました。しかし、このほうがすっきりして上品ともいえます。