ユーザーフォーム入門<br />プログレスバーを自作する
ユーザーフォーム入門<br />プログレスバーを自作する

ユーザーフォーム入門プログレスバーを自作する

VBAで時間のかかる処理の場合、ユーザーはいつ終わるか分からずただひたすら待っているしかありません。そのような場合はVBAの進捗を画面に表示して、今なにをしているか、後どれくらいで終わるかを知らせることで、ユーザーのイライラはかなり解消されます。

'フォーム表示入り口 Public Sub ShowModeless(Optional ByVal strTitle As String = "") 'ラベルコントロール追加 Set pProgressBar = Me.FrameProgress.Controls.Add("Forms.Label.1", "lblProgress") If pBarColor = 0 Then pBarColor = RGB(0, 0, 128) pProgressBar.Width = 0 pProgressBar.Height = Me.FrameProgress.Height pProgressBar.BackColor = pBarColor

'プログレスバーの背景をへこませる Me.FrameProgress.SpecialEffect = fmSpecialEffectSunken

'割込み拒否の設定 If pInteractive = False Then Me.Enabled = False 'これは好みで Application.Interactive = False Application.EnableCancelKey = xlDisabled End If

'フォームをモードレスで表示 Me.Caption = "" Me.Show vbModeless 'モードレス End Sub

'プログレス進捗：指定値 Public Sub Value(ByVal aValue As Double, Optional ByVal strTitle As String = "") 'プログレスバー値変更 pCurValue = aValue

'最大値判定 If pCurValue > pMaxValue Then pCurValue = pMaxValue End If

'プログレスバーの描画 pProgressBar.Width = pCurValue * Me.FrameProgress.Width / pMaxValue If Me.Caption strTitle Then Me.Caption = strTitle End If

'再描画 'Me.Repaint 'これだと「応答なし」が出てしまう DoEvents End Sub

'プログレス進捗：加算 Public Sub ValueAdd(ByVal aValue As Double, Optional ByVal strTitle As String = "") pCurValue = pCurValue + aValue Call Value(pCurValue, strTitle) End Sub

'フォーム終了 Public Sub SelfClose() Unload Me End Sub

'正規終了以外をキャンセル Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then If pInteractive Then If MsgBox("処理を中断しますか?", vbYesNo, "中断確認") = vbYes Then isCancel = True Else Cancel = True End If Else Cancel = True End If End If End Sub

ShowModeless UserForm_Initializeで行っても良いのですが、 UserForm_Initializeは引数を渡せないので、先々に拡張しやすいように引数を渡せるメソッドを使用しています。 ラベルを動的に作成して、プログレスバーとして使用しています。 プログレスバーの最大値や色はプロパティで変更できるようにしています。 Value

プログレスバーを進めるメソッドです。 Me.Repaintだけでも再描画されますが、処理時間がかかるとどうしても「応答なし」になってしまいます。 DoEventsを入れるのが一番無難ですが、処理件数が多いと余計な時間かかってしまう事にもなります。

使用側でDoEventsするなら、ここはMe.Repaintで良いかもしれません。 この辺りは、いろいろと試して使いやすいように適宜変更してください。 ValueAdd プログレスバー値を加算で指定できるようにしています。 SelfClose 使用側でUnloadすれば良いのですが、Showを自作したので、それに対応して作成しています。 serForm_QueryClose 「×」やAlt+F4で閉じられた時の対応になります。 Interactiveプロパティで制御しています。 UserForm_Terminate Interactive = True この時に、Applicationのプロパティを元に戻しています。 今回掲載したVBAは、使い回ししやすいようにユーザーフォームだけでプログレスバーを作成しました。 プログレスバーのバリエーションとして、フォームをモーダル表示で行う方法もあります。 また、クラスを作成してフォームを制御する方法も良いでしょう。 この辺りの詳しい話は、以下に掲載されています。 「プログレスバー」のクラス http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020.html プログレスバーの使用方法1：中断不可

Dim i As Long, j As Long For i = 1 To Progress.MaxValue Progress.Value i, i & "/" & Progress.MaxValue 'いろいろ処理の代わり For j = 1 To 10000000 Next Next

単純な使用例です。 割込みを認めないようにしています。 ユーザー操作でプログレスを閉じることは出来ません。 ※後日追記

エクセルブック以外のウィンドウを開いていると、 フォームを閉じた時にエクセルからフォーカスが外れて他のウィンドウの後ろに隠れてしまいます。 これに対処するには、フォームを閉じた後でAppActivateを使いエクセルをアクティブします。 Progress.SelfCloseの下に、以下のコードを追加してください。 AppActivate Application.Windows(1).Caption

プログレスバーの使用方法2：中断許可 フォルダ内の全てのファイルを処理する場合のサンプルVBAです。 まずは、テスト用データを作成します。

Dim strFolder As String strFolder = ThisWorkbook.Path & "\test" objFSO.CreateFolder strFolder

"test"フォルダを作成して、100文字10000行のデータを作成しています。 削除処理を入れていませんので、再実行するときはフォルダを削除してください。 上記で作成したデータを処理します。

Dim objFSO As Object Dim maxCount As Long Set objFSO = CreateObject("Scripting.FileSystemObject") maxCount = objFSO.GetFolder(strFolder).Files.Count

Dim Progress As New Progress With Progress .MaxValue = maxCount .Interactive = True '割込み許可 .ShowModeless "開始します" End With

Dim objFile As Object Dim strText As String Dim inTs As Object Dim i As Long, j As Long For Each objFile In objFSO.GetFolder(strFolder).Files

If Progress.isCancel Then MsgBox "処理が中断されました。" Exit Sub End If

i = i + 1 Progress.ValueAdd 1, i & "/" & maxCount & " : " & objFile.Name

Set inTs = objFile.OpenAsTextStream strText = inTs.ReadAll inTs.Close 'いろいろ処理 Next

割込みを認めるようにしています。 中断されたときは応答で続行するか確認しています。 プログレスバー自作の最後に

処理時間がそれほど長くない場合はステータスバーで十分でしょう。 処理時間が数十秒以上かかるとか、いろいろなユーザーが使うような場合は、 このようなプログレスバーを表示しておくと、ユーザーも安心すると思います。

今回掲載のVBAは、そのまま使用可能ですが、 ご自身なりに工夫して、いろいろカスタマイズして使用してみてください。 同じテーマ「ユーザーフォーム入門」の記事 新着記事 NEW ・・・新着記事一覧を見る アクセスランキング ・・・ ランキング一覧を見る このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。 掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。 本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。 This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.