ラベルを利用したプログレスバー

　ラベルを利用してプログレスバーを作成します。

Option Compare Database
Option Explicit

'==================================================
'
'１．適当にフォームを作成
'
'２．フォームにラベルを作成
'   名前    : lblprogressbar
'   可視    ：いいえ
'   標題    ：適当
'   大きさ  ：適当
'   文字の色：青
'   立体表示：くぼみ
'
'３．ボタンの作成
'   名前    : btExec
'   標題    : 実行

'４．ボタンの作成(フォーカス設定ダミーボタン)
'   名前    : btDummy
'   透明    ：はい
'
'５．以下のコードをコピペして実行
'
'==================================================

Private exec_cnt      As Long                   '検索済件数
Private exec_all      As Long                   '全検索件数

Private Const CNST_PGB_REPAINT_INTERVAL = 10    '指定件数毎にプログレスバーを更新する

Private Sub btExec_Click()

    Dim i As Long
    
    '-----------------------------------------------------
    '   初期設定
    '-----------------------------------------------------
    progressbar_init    'プログレスバーを初期化する
    exec_cnt = 0        '処理している件数
    exec_all = 100000   '全処理件数
    ctl_Enabled         'コントロールの使用不可

    '-----------------------------------------------------
    '   適当な処理
    '-----------------------------------------------------
    For i = 1 To 100000

        exec_cnt = exec_cnt + 1 '処理インクリメント

    '-----------------------------------------------------
    '   指定件数毎にプログレスバーを更新する
    '-----------------------------------------------------
        If exec_cnt Mod CNST_PGB_REPAINT_INTERVAL = 0 Then progressbar_control

        '〜〜〜〜〜〜〜〜
        '   処理
        '〜〜〜〜〜〜〜〜
        
    Next i

    '-----------------------------------------------------
    '   終了処理
    '-----------------------------------------------------
    ctl_Enabled         'コントロールの使用不可解除
    progressbar_init    'プログレスバーを初期化する

End Sub

'---------------------------------------------------------------
' 押されたくないコントロールを使用不可にする(DoEvents対応)
'---------------------------------------------------------------
Function ctl_Enabled()

    btDummy.SetFocus    'ダミーにフォーカス設定
    btExec.Enabled = Not btExec.Enabled
    
End Function

'-----------------------------------------------
' プログレスバー初期化
'-----------------------------------------------
Function progressbar_init()
 
    lblprogressbar.Visible = Not lblprogressbar.Visible '可視設定
    lblprogressbar.Caption = ""                         'CAPTION クリア
    Me.Repaint                                          '再表示
    DoEvents

End Function

'-----------------------------------------------
' プログレスバー初期化
'-----------------------------------------------
Function progressbar_control()

    Dim rate As Long
    Dim bar  As String
    
    '割合
    rate = exec_cnt / exec_all * 100

    'プログレスバーのCaption
    Select Case rate
    Case 1 To 5: bar = "■"
    Case 6 To 10: bar = "■■"
    Case 11 To 15: bar = "■■■"
    Case 16 To 20: bar = "■■■■"
    Case 21 To 25: bar = "■■■■■"
    Case 26 To 30: bar = "■■■■■■"
    Case 31 To 35: bar = "■■■■■■■"
    Case 36 To 40: bar = "■■■■■■■■"
    Case 41 To 45: bar = "■■■■■■■■■"
    Case 46 To 50: bar = "■■■■■■■■■■"
    Case 51 To 55: bar = "■■■■■■■■■■■"
    Case 56 To 60: bar = "■■■■■■■■■■■■"
    Case 61 To 65: bar = "■■■■■■■■■■■■■"
    Case 66 To 70: bar = "■■■■■■■■■■■■■■"
    Case 71 To 75: bar = "■■■■■■■■■■■■■■■"
    Case 76 To 80: bar = "■■■■■■■■■■■■■■■■"
    Case 81 To 85: bar = "■■■■■■■■■■■■■■■■■"
    Case 86 To 90: bar = "■■■■■■■■■■■■■■■■■■"
    Case 91 To 95: bar = "■■■■■■■■■■■■■■■■■■■"
    Case 96 To 100: bar = "■■■■■■■■■■■■■■■■■■■■"
    End Select

    'プログレスバーに設定
    lblprogressbar.Caption = bar

    '再表示
    Me.Repaint
    DoEvents

End Function