【VBA】オリジナルプログレスバーを実装する

0

    <機能>

    (1)オリジナル(独自)のプログレスバーを作成します

     ※ActiveXのプログレスバーは使用しません

    (2)フレームの中に背景が緑のラベルを配置してWidth変更により進捗表示します

    (3)透明ラベルにて進捗「999 / 999 %」を表示します

    (4)キャンセル(中断)押下により処理を中断できます

     

    <動作検証&開発環境>
    Microsoft Office2016

     

    <実行イメージ>

    ユーザフォーム表示直後のイメージ

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    窪んだフレーム中の緑のラベルのWidthを変化させます

    進捗表示ラベルは背景を透明に設定しています

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    キャンセル押下により中断できます

    [X]ボタンや[Alt]+[F4]でも同じ動作をします

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

     

    <使い方>
    (1)[挿入]メニューからユーザフォームを挿入します
    ※名前はUserForm1(デフォルト名)とします

    プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

    (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
     

     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     



    calendar

    S M T W T F S
         12
    3456789
    10111213141516
    17181920212223
    24252627282930
    << September 2017 >>

    profile

    others

    mobile

    qrcode