プログレスバー
｜フォーム ｜バー表示 ｜進行中回数計算 ｜プログレス表示 ｜ダイアログを閉じる ｜終了メッセージ｜
｜テストマクロ ｜ループ処理｜

処理の進捗状況を表示するためのフォームのラベルを使ったプログレスバーです。
このマクロを実行すると下のようになります。
prog_01
フォーム▲ TOP
新規にユーザーフォーム ( FProgress ) を作成し、ラベルを四つ配置します。
  1. Label1 → プログレスバーの枠の部分
  2. Label2 → プログレスバーのバーの部分　BackColor　黄色　 &H0000FFFF&
  3. Label3 → 進捗状況表示の部分 ( % )
  4. Label4 → メッセージ表示の部分
  5. Label1 〜 3 は、ほぼ同じ位置に配置し動作させて微調整をする。
1.ユーザーフォーム
prog10
2.Label 1
prog11
2.Label 2
prog12
3.Label 3
prog13
4.Label 4
prog14
プログレスバー表示▲ TOP
Option Explicit

Public mypbProgCnt As Integer       'Progress カウンター変数
Public mypbSCount As Integer        '処理回数

Dim myJobCnt As Integer             '現在進行中の回数
Dim myBarSize As Integer            'プログレスバーサイズ

Public Sub ProgShowStart(myTitle As String)

''プログレスバー表示    2001/7/5

    Dim myMsg1 As String
    
'    myMsg1 = CStr(mypbProgCnt - 1) & "/" & CStr(mypbSCount)
    myMsg1 = myTitle & " 処理中"
'    myMsg1 = myTitle & mypbProgCnt & "/" & mypbSCount

''ダイアログへ表示
    With FProgress
        .StartUpPosition = 0
        .Caption = myTitle
        .Top = 130
        .LEFT = 240
        .Height = 70
        .Width = 144
        
    ''プログレスバーの枠の部分
''        .Label1.BorderStyle = fmBorderStyleSingle       '枠あり
        .Label1.SpecialEffect = fmSpecialEffectSunken   '
        .Label1.Height = 15
        .Label1.LEFT = 12
        .Label1.Width = 115
        .Label1.Top = 30

    ''プログレスバーのバーの部分
        .Label2.BackColor = RGB(255, 255, 0)
        .Label2.BorderStyle = fmBorderStyleSingle       '枠あり
        .Label2.Height = 13
        .Label2.LEFT = 13
        .Label2.Width = 0
        .Label2.Top = 31

    ''進捗状況表示の部分 ( % )
        .Label3.TextAlign = fmTextAlignCenter
        .Label3.BackStyle = 0
        .Label3.Height = 14
        .Label3.LEFT = 12
        .Label3.Width = 113
    '        .Label3.Top = 31
        .Label3.Top = 32
        .Label3.Font.Size = 10
        .Label3.Font.Bold = True                'false 標準 true 太字

    ''メッセージ表示の部分
'        .Label4.TextAlign = fmTextAlignCenter
        .Label4.Caption = myMsg1
'        .Label4.SpecialEffect = fmSpecialEffectEtched   '枠が沈む
'        .Label4.SpecialEffect = fmSpecialEffectRaised   '浮き上がる
'        .Label4.SpecialEffect = fmSpecialEffectBump   '
        .Label4.Height = 14
        .Label4.LEFT = 12
        .Label4.Width = 120
        .Label4.Top = 9
        .Label4.Font.Size = 9
        .Label4.Font.Bold = True                'false 標準 true 太字

        myBarSize = .Label3.Width
    End With
    FProgress.Show vbModeless
End Sub
進行中回数計算▲ TOP
Public Sub ProgShowCount(myTitle As String)

''進行中回数計算

    Dim myMsg1 As String
    Dim myMsg2 As String
    
    myMsg1 = "処理中    " & mypbProgCnt & " / " & mypbSCount
    
    myJobCnt = mypbProgCnt / mypbSCount * 100
    myMsg2 = Int(myJobCnt) & " %"
    
    With FProgress
        .Label2.Width = myBarSize * myJobCnt / 100
        .Label3.Caption = myMsg2
        .Label4.Caption = myMsg1
    End With
End Sub
プログレス表示▲ TOP
Public Sub ProgShowEvent()

''プログレス表示
    DoEvents
End Sub
ダイアログを閉じる▲ TOP
Public Sub ProgShowClose()

''ダイアログを閉じる
    Unload FProgress
End Sub
終了メッセージ▲ TOP
Public Sub ProgShowEnd(myTitle As String)

''終了メッセージ
    Dim myMsg1 As String
    
'    myMsg1 = "終了しました。"
'    myMsg1 = myTitle & "  " & mypbProgCnt - 1 & "/" & mypbSCount
'    myMsg1 = myTitle & "  終了"
    myMsg1 = myTitle & "  " & mypbSCount & " 件"
    
    Beep
    With FProgress
        .Label4.Caption = myMsg1
    End With

End Sub
テストマクロ▲ TOP
Option Explicit

Sub progtest()

    Dim mycMsg1 As String
    
    mycMsg1 = "Progress Test"          'Progress Bar タイトル
    mypbSCount = 20                    '処理回数

    LoopCom01 mycMsg1
End Sub
ループ処理▲ TOP
Sub LoopCom01(mycMsg1 As String)

''ループ処理 1   2002/8/29

    Dim mycTitle As String
    
    mycTitle = mycMsg1

    Application.Calculation = xlManual          '再計算手動
    
    Application.ScreenUpdating = False          '画面のちらつき防止

    ProgShowStart (mycTitle)
    For mypbProgCnt = 1 To mypbSCount
        ProgShowCount (mycTitle)
        ProgShowEvent
        Macrohome
        
        ''繰り返し処理させるマクロ
        LoopCom02
        
        ''実行中のマクロを約 1 秒間停止(確認のためで実際はコメントにする)
        Application.Wait (Now + TimeValue("0:00:01"))
    Next
    
    Application.ScreenUpdating = True           '画面のちらつき防止解除
    
    ProgShowEnd (mycTitle)
    
    Application.Calculation = xlAutomatic       '再計算自動
   
End Sub

Sub LoopCom02()

    Dim myi As Integer
    
    For myi = 1 To 10
        myi = 1 + myi
    Next

End Sub
top