【VBA】オリジナルプログレスバーを実装する
<機能>
(1)オリジナル(独自)のプログレスバーを作成します
※ActiveXのプログレスバーは使用しません
(2)フレームの中に背景が緑のラベルを配置してWidth変更により進捗表示します
(3)透明ラベルにて進捗「999 / 999 %」を表示します
(4)キャンセル(中断)押下により処理を中断できます
<動作検証&開発環境>
Microsoft Office2016
<実行イメージ>
ユーザフォーム表示直後のイメージ
窪んだフレーム中の緑のラベルのWidthを変化させます
進捗表示ラベルは背景を透明に設定しています
キャンセル押下により中断できます
[X]ボタンや[Alt]+[F4]でも同じ動作をします
<使い方>
(1)[挿入]メニューからユーザフォームを挿入します
※名前はUserForm1(デフォルト名)とします
(2)コントロールを配置します
・Frame1
Caption : なし
Width : 400
SpecialEffect : fmSpecialEffectSunken(窪みフレーム)
・Label1
BackColor : 緑(なんでもいいです)
Caption : なし
Width : 400(フレームの中に配置)
・Label2
BackStyle : mBackStyleTransparent(背景透明)
TextAlign : fmTextAlignCenter(中央揃え)
・CommandButton1
Caption : スタート
・CommandButton2
Caption : キャンセル
(3)ソースをUserForm1に貼り付けます
'//Windows API
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_NOMOVE As Long = &H2&
'//キャンセルボタン押下判定フラグ
Public bCancel As Boolean
'//プログレスバー実行中フラグ
Public bProgress As Boolean
'/********************************************************
'/* ユーザフォームを常に前面に表示
'/********************************************************
Private Sub UserForm_Activate()
Call SetWindowPos(GetForegroundWindow, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
'/********************************************************
'/* ユーザフォームの初期化
'/********************************************************
Private Sub UserForm_Initialize()
'//ラベルの位置を明示的に指定
'//フレーム(Frame1)とラベル(Label1)の左上座標&幅を合わせる
With Me.Label1
.Left = 0
.Top = 0
.Width = 400
.Visible = False
End With
'//ラベル2(プログレスバーの進捗表示用)初期表示
Me.Label2.Caption = "スタートボタンを押してください"
'//キャンセルボタン押下フラグ
bCancel = False
'//プログレスバー実行中フラグ
bProgress = False
End Sub
'/********************************************************
'/* [スタート]押下によりプログレスバー開始
'/********************************************************
Private Sub CommandButton1_Click()
Dim iBar As Integer
Dim strMsg As String
'//初期値セット
iBar = 0
bCancel = False
strMsg = "おわりました"
'//プログレスバー(ラベル)は最初は幅0
Me.Label1.Width = 0
Me.Label1.Visible = True
'//ラベル2(プログレスバーの進捗表示用)は0を初期表示
Me.Label2.Caption = " 0 / 100 %"
'//プログレスバー開始
bProgress = True
Do
'0-100まで
If iBar = 100 Then Exit Do
'200ミリ秒ごとにカウントアップ
'大括弧[]で囲むとSleepを使わなくてもミリ秒指定が可能です
'Application.Wait Now + TimeValue("0:00:01")
Application.Wait [Now() + "0:00:00.2"]
iBar = iBar + 1
'ラベルの幅を400としているのでカウンター×4とする
Me.Label1.Width = (iBar * 4)
'進捗表示(分子はスペース埋めで3桁固定とする)
Me.Label2.Caption = Format(CStr(iBar), "@@@") & " / 100 %"
'再描画
Me.Repaint
'キャンセルボタン押下等のイベント処理
DoEvents
If bCancel Then
If MsgBox("キャンセルしてもよろしいですか?", vbQuestion + vbYesNo) = vbYes Then
'メッセージで[はい]が押下されたらキャンセルする
strMsg = "キャンセルされました"
Exit Do
Else
'メッセージで[いいえ]が押下されたらキャンセル処理をスキップ
bCancel = False
End If
End If
Loop
'//プログレスバー終了
bProgress = False
'//終了メッセージ表示
MsgBox strMsg, vbInformation
End Sub
'/********************************************************
'/* [キャンセル]押下イベントハンドラ
'/********************************************************
Private Sub CommandButton2_Click()
'//キャンセル処理へ進む
bCancel = True
End Sub
'/********************************************************
'/* 「x」ボタンでフォームを閉じないようにする
'/********************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'//プログレスバー実行中に「x」またはAlt+F4でフォームを閉じようとしたとき
If bProgress Then
If CloseMode = vbFormControlMenu Then
'//キャンセル処理へ進む
bCancel = True
'//閉じるボタン「x」では閉じない
Cancel = True
End If
End If
End Sub
よろしければポチッと押してください