



'***************************************************************************************************
'   プログレスバーをコントロールするクラス(テスト用標準Module)      Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/11/02(1.10)64ビット版Excelの対応(API関連)
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Public Const g_cnsTitle As String = "プログレスバーのサンプル"
' ■スリープ(これは本サンプル用に必要なだけです)
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" _
    (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "KERNEL32.dll" _
    (ByVal dwMilliseconds As Long)
#End If
Public g_objProgress As clsProgressBar1
'***************************************************************************************************
'   ■■■ 公開プロシージャ ■■■
'***************************************************************************************************
'* 処理名 :SYORI_START
'* 機能  :起動処理 ※本サンプルではこの処理がシートのボタンから起動されます。
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub SYORI_START()
    '-----------------------------------------------------------------------------------------------
    ' クラス[clsProgressBar1]のインスタンスを生成
    Set g_objProgress = New clsProgressBar1
    With g_objProgress
        ' プログレスバー表示で実際の実行をするマクロ名を登録
        .Macro = "SYORI1"  ' バッチメイン処理(Proc名)
        ' プログレスバーのCaption(タイトル)の登録
        .Caption = g_cnsTitle
        ' プログレスバーの閉じる[×]ボタンを表示するかのスイッチ設定
        .ShowBox = False    ' Trueにすると表示されます。
        ' Escキーでの中断機能の使用有無のスイッチ設定
        .EscStop = True     ' Falseにすると一切止まらなくなります。
        ' プログレスバーフォームを起動(「SYORI1」はフォームから起動される)
        .Show
    End With
    ' クラス[clsProgressBar1]のインスタンスを破棄
    Set g_objProgress = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :SYORI1
'* 機能  :処理実行中(プログレスバー)を表示する実際の処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub SYORI1()
    '-----------------------------------------------------------------------------------------------
    ' クラス[clsProgressBar1]に対する処理
    With g_objProgress
        ' 最大件数のセット(普通は定数ではないですね)
        .Max = 1000
        ' 繰り返し(限度判定はこの方法とは限らない)
        Do While .Value <= .Max
            ' 中断判定
            If .Tag = 9 Then Exit Do
            ' 処理件数を加算
            .Value = .Value + 1
            '-----------------------------------------------
            ' ■■■ここで実際の1件分の処理を行なう■■■
            Sleep 10    ' これはサンプルなのでちょっと時間を消費
            '-----------------------------------------------
        Loop
        ' 終了(フォームを閉じる)
        .Hide
    End With
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
'   プログレスバーをコントロールするクラス                      clsProgressBar1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
'===================================================================================================
' クラス側で保持する変数(隠蔽)
Private g_lngWidth As Long                                          ' Width
Private g_lngNow As Long                                            ' 現在件数
Private g_lngMax As Long                                            ' 最大件数
Private g_strCaption As String                                      ' プログレスバーのタイトル
Private g_strMacro As String                                        ' 起動させるプロシージャ名
Private g_lngTag As Long                                            ' 中断指示
Private g_blnSwShow As Boolean                                      ' 閉じる[×]ボタン表示スイッチ
Private g_blnSwStop As Boolean                                      ' 中断機能の使用有無スイッチ
'***************************************************************************************************
' ■■■ メソッド ■■■
'***************************************************************************************************
'* 処理名 :Show
'* 機能  :Showメソッド
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Sub Show()
    '-----------------------------------------------------------------------------------------------
    g_lngWidth = 0
    g_lngTag = 0
    With frmProgressBar1
        .Height = 54
        ' 制御情報は一旦ラベルに持たせておく
        .LBL_Macro.Visible = g_blnSwShow        ' 閉じる[×]ボタン表示
        .LBL_Macro.WordWrap = g_blnSwStop       ' 中断機能の使用有無
        .LBL_Macro.Caption = g_strMacro         ' プロシージャ名
        .Caption = g_strCaption                 ' フォームタイトル
        .Show                                   ' プログレスバーフォームの表示
    End With
    g_lngTag = 9
    Unload frmProgressBar1
End Sub
'***************************************************************************************************
'* 処理名 :Hide
'* 機能  :Hideメソッド
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Sub Hide()
    '-----------------------------------------------------------------------------------------------
    frmProgressBar1.Hide
    DoEvents
End Sub
'***************************************************************************************************
' ■■■ プロパティ ■■■
'***************************************************************************************************
' 最大件数の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Max() As Long
    Max = g_lngMax
End Property
Friend Property Let Max(ByVal lngNewMax As Long)
    g_lngMax = lngNewMax
End Property
'===================================================================================================
' 現在件数の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Value() As Long
    Value = g_lngNow
End Property
Friend Property Let Value(ByVal lngNewValue As Long)
    Dim lngWidth As Long                                            ' 幅
    g_lngNow = lngNewValue
    If g_lngNow >= g_lngMax Then
        frmProgressBar1.Fm_ProgressBar.Width = 200
        frmProgressBar1.Hide
        Exit Property
    End If
    ' Widthの計算
    lngWidth = Int(g_lngNow * 200& / g_lngMax)
    If lngWidth = g_lngWidth Then Exit Property
    ' プログレスバーの長さを変更
    frmProgressBar1.Fm_ProgressBar.Width = lngWidth
    DoEvents
    g_lngWidth = lngWidth
    g_lngTag = frmProgressBar1.Tag
End Property
'===================================================================================================
' プログレスバーから起動させるプロシージャ名の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Macro() As String
    Macro = g_strMacro
End Property
Friend Property Let Macro(ByVal strNewMacro As String)
    g_strMacro = strNewMacro
End Property
'===================================================================================================
' プログレスバーのタイトルの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Caption() As String
    Caption = g_strCaption
End Property
Friend Property Let Caption(ByVal strNewCaption As String)
    g_strCaption = strNewCaption
End Property
'===================================================================================================
' 閉じる[×]ボタン表示スイッチの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get ShowBox() As Boolean
    ShowBox = g_blnSwShow
End Property
Friend Property Let ShowBox(ByVal blnSwShow As Boolean)
    g_blnSwShow = blnSwShow
End Property
'===================================================================================================
' 中断機能の使用有無スイッチの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get EscStop() As Boolean
    ShowBox = g_blnSwStop
End Property
Friend Property Let EscStop(ByVal blnSwStop As Boolean)
    g_blnSwStop = blnSwStop
End Property
'===================================================================================================
' 中断指示の取得(Tag=9が中断指示)
'---------------------------------------------------------------------------------------------------
Friend Property Get Tag() As Long
    Tag = g_lngTag
End Property
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
'   プログレスバーを表示するフォーム本体                        frmProgressBar1(UserForm)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/11/02(1.10)64ビット版Excelの対応(API関連)
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
' 64ビット対応
#If VBA7 Then
    #If Win64 Then
        ' ウィンドウに関する情報を返す
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long) As LongPtr
        ' ウィンドウの属性を変更
        Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32.dll" _
            Alias "SetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        ' ウィンドウに関する情報を返す
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long) As LongPtr
        ' ウィンドウの属性を変更
        Private Declare Function SetWindowLongPtr Lib "USER32.dll" _
            Alias "SetWindowLongA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #End If
' Activeなウィンドウのハンドルを取得
Private Declare PtrSafe Function GetActiveWindow Lib "USER32.dll" _
    () As LongPtr
' メニューバーを再描画
Private Declare PtrSafe Function DrawMenuBar Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As LongPtr
#Else
' ウィンドウに関する情報を返す
Private Declare Function GetWindowLong Lib "USER32.dll" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
' ウィンドウの属性を変更
Private Declare Function SetWindowLong Lib "USER32.dll" _
    Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, _
     ByVal dwNewLong As Long) As Long
' Activeなウィンドウのハンドルを取得
Private Declare Function GetActiveWindow Lib "USER32.dll" _
    () As Long
' メニューバーを再描画
Private Declare Function DrawMenuBar Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
#End If
'***************************************************************************************************
'   ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 :CMD_CANCEL_Click
'* 機能  :キャンセル(隠しボタン)のイベント(Escキーで本イベントが発生する)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CMD_CANCEL_Click()
    '-----------------------------------------------------------------------------------------------
    ' 中断機能の使用有無はラベルのWordWrapプロパティを使う
    If LBL_Macro.WordWrap = True Then
        If MsgBox("キャンセルキーが押されました。" & _
            "ここで中断して終了しますか?", _
            vbInformation + vbYesNo, g_cnsTitle) = vbYes Then
            Me.Tag = 9
        End If
    End If
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_Activate
'* 機能  :フォームの表示初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Activate()
    '-----------------------------------------------------------------------------------------------
#If VBA7 Then
    Dim hWnd As LongPtr
    Dim Wnd_STYLE As LongPtr
#Else
    Dim hWnd As Long
    Dim Wnd_STYLE As Long
#End If
    ' 閉じる[×]ボタンの有効/無効はラベルのVisibleプロパティを使う
    If LBL_Macro.Visible <> True Then
        ' 閉じる[×]ボタンを無効にする
        hWnd = GetActiveWindow()
#If VBA7 Then
        Wnd_STYLE = GetWindowLongPtr(hWnd, GWL_STYLE)
        Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU)
        SetWindowLongPtr hWnd, GWL_STYLE, Wnd_STYLE
#Else
        Wnd_STYLE = GetWindowLong(hWnd, GWL_STYLE)
        Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU)
        SetWindowLong hWnd, GWL_STYLE, Wnd_STYLE
#End If
        DrawMenuBar hWnd
    End If
    Me.Tag = 0
    Fm_ProgressBar.Width = 0.01
    ' 実際の処理の起動
    Application.Run Macro:=LBL_Macro.Caption
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_QueryClose
'* 機能  :Closeイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '-----------------------------------------------------------------------------------------------
    ' 閉じる[×]ボタンは許可しない(表示されない場合は動作しない)
    If CloseMode = vbFormControlMenu Then
        ' Escキーと同様処理とする
        Call CMD_CANCEL_Click
        Cancel = True
    End If
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
|  | ←ProgressBar1.zip (33KB) | 

'***************************************************************************************************
'   プログレスバーをコントロールするクラス(テスト用標準Module)      Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/11/02(1.10)64ビット版Excelの対応(API関連)
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Private Const g_cnsTitle As String = "プログレスバーのサンプル"
#If VBA7 Then
' ■スリープ(これは本サンプル用に必要なだけです)
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" _
    (ByVal dwMilliseconds As Long)
#Else
' ■スリープ(これは本サンプル用に必要なだけです)
Private Declare Sub Sleep Lib "KERNEL32.dll" _
    (ByVal dwMilliseconds As Long)
#End If
'***************************************************************************************************
'   ■■■ 公開プロシージャ ■■■
'***************************************************************************************************
'* 処理名 :SYORI_START
'* 機能  :起動処理 ※本サンプルではこの処理がシートのボタンから起動されます。
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub MAIN_SYORI()
    '-----------------------------------------------------------------------------------------------
    Dim lngCNT_MAX As Long                                          ' 最大件数
    Dim lngCNT_NOW As Long                                          ' 現在件数
    ' クラス[clsProgressBar2]のインスタンスを生成
    Set g_objProgress2 = New clsProgressBar2
    '===============================================================================================
    '  ■初期処理
    '-----------------------------------------------------------------------------------------------
    ' プログレスバーのCaption(タイトル)の登録
    g_objProgress2.Caption = g_cnsTitle
    ' プログレスバーの閉じる[×]ボタンを表示するかのスイッチ設定
    ' ※記述しない場合は「False(初期値)」で動作します。
    g_objProgress2.ShowBox = False    ' Trueにすると表示されます。
    ' Escキーでの中断機能の使用有無のスイッチ設定
    ' ※記述しない場合は「True(初期値)」で動作します。
    g_objProgress2.EscStop = True     ' Falseにすると一切止まらなくなります。
    ' 最大件数のセット(普通は定数ではないですね)
    lngCNT_MAX = 1000
    ' Maxプロパティに最大件数をセット
    ' ※Showの後で変更しても構いません
    g_objProgress2.Max = lngCNT_MAX
    ' プログレスバーフォームを起動(Modeless)
    g_objProgress2.Show
    On Error GoTo ERR_STOP
    '===============================================================================================
    '  ■メイン処理
    '-----------------------------------------------------------------------------------------------
    ' 繰り返し(限度判定はこの方法とは限らない)
    Do While lngCNT_NOW <= lngCNT_MAX
        ' 中断判定
        If g_objProgress2.Tag = 9 Then Exit Do
        DoEvents
        ' 処理件数を加算
        lngCNT_NOW = lngCNT_NOW + 1
        ' 処理件数をValueプロパティにセット
        g_objProgress2.Value = lngCNT_NOW
        g_objProgress2.StatusBar = lngCNT_NOW & " / " & lngCNT_MAX
        '-----------------------------------------------------------------------
        ' ■■■ここで実際の1件分の処理を行なう■■■
        Sleep 10    ' これはサンプルなのでちょっと時間を消費
        '-----------------------------------------------------------------------
    Loop
    '===============================================================================================
    '  ■終了処理
    '-----------------------------------------------------------------------------------------------
    ' 終了(フォームを閉じる)
    g_objProgress2.Hide
    ' クラス[clsProgressBar2]のインスタンスを破棄
    Set g_objProgress2 = Nothing
    Exit Sub
'===================================================================================================
' 中断処理
ERR_STOP:
    ' ユーザー割り込みかを判定
    If Err.Number = 18 Then
        ' 終了しない場合は戻る(クラス側で確認処理)
        If g_objProgress2.EscKey() <> True Then Resume
    Else
        ' その他のエラーはメッセージ処置などを行なう
        MsgBox Err.Description, vbCritical, g_cnsTitle
    End If
    ' クラス[clsProgressBar2]のインスタンスを破棄
    Set g_objProgress2 = Nothing
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
'   プログレスバーをコントロールするクラス                      clsProgressBar2(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
'===================================================================================================
' クラス側で保持する変数(隠蔽)
Private g_lngWidth As Long                                          ' Width
Private g_lngNow As Long                                            ' 現在件数
Private g_lngMax As Long                                            ' 最大件数
Private g_strCaption As String                                      ' プログレスバーのタイトル
Private g_strMessage As String                                      ' Window内上部のメッセージ
Private g_strStatusBar As String                                    ' ステータスバー
Private g_lngTag As Long                                            ' 中断指示
Private g_blnSwShow As Boolean                                      ' 閉じる[×]ボタン表示スイッチ
Private g_blnSwStop As Boolean                                      ' 中断機能の使用有無スイッチ
Private g_lngEnableCancelKey As Long                                ' Escキー動作の保管
'***************************************************************************************************
' ■■■ イベント ■■■
'***************************************************************************************************
'* 処理名 :Class_Initialize
'* 機能  :クラス初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Class_Initialize()
    '-----------------------------------------------------------------------------------------------
#If VBA6 Or VBA7 Then
    ' デフォルト値のセット
    g_blnSwShow = False                         ' 閉じる[×]ボタン表示
    g_blnSwStop = True                          ' 中断機能の使用有無
    g_strMessage = "処理中です。しばらくお待ち下さい...."
    g_strStatusBar = ""
    ' Escキー動作を保管
    g_lngEnableCancelKey = Application.EnableCancelKey
#Else
    ' Excel97以前ではModeLessユーザーフォームは利用不可
    MsgBox "この処理はExcel2000以降で動作します。", vbExclamation
    End
#End If
End Sub
'***************************************************************************************************
'* 処理名 :Class_Terminate
'* 機能  :クラス終了
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Class_Terminate()
    '-----------------------------------------------------------------------------------------------
    Unload frmProgressBar2
    ' Escキー動作を復帰
    Application.EnableCancelKey = g_lngEnableCancelKey
End Sub
'***************************************************************************************************
' ■■■ メソッド ■■■
'***************************************************************************************************
'* 処理名 :Show
'* 機能  :Showメソッド
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Sub Show()
    '-----------------------------------------------------------------------------------------------
    g_lngWidth = 0
    g_lngTag = 0
    With frmProgressBar2
        .Height = 81
        ' 制御情報は一旦ラベルに持たせておく
        .LBL_Macro.Visible = g_blnSwShow        ' 閉じる[×]ボタン表示
        .LBL_Macro.WordWrap = g_blnSwStop       ' 中断機能の使用有無
        If g_blnSwStop = True Then
            ' 中断キーを使用する場合
            Application.EnableCancelKey = xlErrorHandler
        Else
            ' 中断キーを使用しない場合
            Application.EnableCancelKey = xlDisabled
        End If
        .Caption = g_strCaption                 ' フォームタイトル
        .LBL_Message = g_strMessage             ' フォーム画面メッセージ
        .LBL_StatusBar = g_strStatusBar         ' フォームステータス表示
        .Show vbModeless                        ' プログレスバーの表示(モードレス)
        DoEvents
    End With
End Sub
'***************************************************************************************************
'* 処理名 :Hide
'* 機能  :Hideメソッド
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Sub Hide()
    '-----------------------------------------------------------------------------------------------
    frmProgressBar2.Hide
    DoEvents
End Sub
'***************************************************************************************************
'* 処理名 :EscKey
'* 機能  :Escキー押下メソッド(フォームがアクティブでない場合の対応)
'---------------------------------------------------------------------------------------------------
'* 返り値 :終了判定(Boolean)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Function EscKey() As Boolean
    '-----------------------------------------------------------------------------------------------
    If MsgBox("キャンセルキーが押されました。" & _
        "ここで中断して終了しますか?", _
        vbInformation + vbYesNo, Me.Caption) = vbYes Then
        frmProgressBar2.Tag = 9
        g_lngTag = 9
        EscKey = True                   ' 終了する(True)
    Else
        EscKey = False                  ' 終了しない(False)
    End If
End Function
'***************************************************************************************************
' ■■■ プロパティ ■■■
'***************************************************************************************************
' 最大件数の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Max() As Long
    Max = g_lngMax
End Property
Friend Property Let Max(ByVal lngNewMax As Long)
    g_lngMax = lngNewMax
End Property
'===================================================================================================
' 現在件数の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Value() As Long
    Value = g_lngNow
End Property
Friend Property Let Value(ByVal lngNewValue As Long)
    Dim lngWidth As Long, lngTag As Long
    On Error GoTo Value_Error
    g_lngNow = lngNewValue
    If g_lngNow >= g_lngMax Then
        frmProgressBar2.Fm_ProgressBar.Width = 200
        frmProgressBar2.Hide
        Exit Property
    End If
    ' Widthの計算
    lngWidth = Int(g_lngNow * 200& / g_lngMax)
    ' 長さに変動がなければ終了
    If lngWidth = g_lngWidth Then Exit Property
    ' プログレスバーの長さを変更
    frmProgressBar2.Fm_ProgressBar.Width = lngWidth
    DoEvents
    g_lngWidth = lngWidth
    lngTag = Val(frmProgressBar2.Tag)
    If lngTag = 9 Then g_lngTag = lngTag
    Exit Property
'===================================================================================================
' エラー処理(中断キーの対応)
Value_Error:
    If Err.Number = 18 Then
        Call EscKey
    Else
        MsgBox Err.Description, vbCritical, g_strCaption
        frmProgressBar2.Tag = 9
        g_lngTag = 9
        DoEvents
    End If
End Property
'===================================================================================================
' プログレスバーのタイトルの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Caption() As String
    Caption = g_strCaption
End Property
Friend Property Let Caption(ByVal strNewCaption As String)
    g_strCaption = strNewCaption
End Property
'===================================================================================================
' プログレスバーの画面メッセージの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get Message() As String
    Message = g_strMessage
End Property
Friend Property Let Message(ByVal strNewMessage As String)
    g_strMessage = strNewMessage
    If g_blnShowProgressBar2 = True Then
        frmProgressBar2.LBL_Message.Caption = g_strMessage
        DoEvents
    End If
End Property
'===================================================================================================
' プログレスバーのステータス表示の取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get StatusBar() As String
    StatusBar = g_strStatusBar
End Property
Friend Property Let StatusBar(ByVal strNewStatusBar As String)
    g_strStatusBar = strNewStatusBar
    If g_blnShowProgressBar2 = True Then
        frmProgressBar2.LBL_StatusBar.Caption = g_strStatusBar
        DoEvents
    End If
End Property
'===================================================================================================
' 閉じる[×]ボタン表示スイッチの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get ShowBox() As Boolean
    ShowBox = g_blnSwShow
End Property
Friend Property Let ShowBox(ByVal blnSwShow As Boolean)
    g_blnSwShow = blnSwShow
End Property
'===================================================================================================
' 中断機能の使用有無スイッチの取得、設定
'---------------------------------------------------------------------------------------------------
Friend Property Get EscStop() As Boolean
    ShowBox = g_blnSwStop
End Property
Friend Property Let EscStop(ByVal blnSwStop As Boolean)
    g_blnSwStop = blnSwStop
End Property
'===================================================================================================
' 中断指示の取得(Tag=9が中断指示)
'---------------------------------------------------------------------------------------------------
Friend Property Get Tag() As Long
    On Error Resume Next
    Tag = g_lngTag
    If Err.Number = 18 Then Call EscKey
End Property
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
'   プログレスバー(frmProgressBar2)をコントロールする(共通変数)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
' クラス(clsProgressBar2)のインスタンス
Public g_objProgress2 As clsProgressBar2
' ProgressBarの表示有無スイッチ
Public g_blnShowProgressBar2 As Boolean
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
'   プログレスバーを表示するフォーム本体                        frmProgressBar2(UserForm)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/08/19(1.00)新規作成
'19/11/02(1.10)64ビット版Excelの対応(API関連)
'19/12/29(1.11)処理記述整理(標準化準拠)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
' 64ビット対応
#If VBA7 Then
    #If Win64 Then
        ' ウィンドウに関する情報を返す
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long) As LongPtr
        ' ウィンドウの属性を変更
        Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32.dll" _
            Alias "SetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        ' ウィンドウに関する情報を返す
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long) As LongPtr
        ' ウィンドウの属性を変更
        Private Declare Function SetWindowLongPtr Lib "USER32.dll" _
            Alias "SetWindowLongA" _
            (ByVal hWnd As LongPtr, _
             ByVal nIndex As Long, _
             ByVal dwNewLong As LongPtr) As LongPtr
    #End If
' Activeなウィンドウのハンドルを取得
Private Declare PtrSafe Function GetActiveWindow Lib "USER32.dll" _
    () As LongPtr
' メニューバーを再描画
Private Declare PtrSafe Function DrawMenuBar Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As LongPtr
#Else
' ウィンドウに関する情報を返す
Private Declare Function GetWindowLong Lib "USER32.dll" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
' ウィンドウの属性を変更
Private Declare Function SetWindowLong Lib "USER32.dll" _
    Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, _
     ByVal dwNewLong As Long) As Long
' Activeなウィンドウのハンドルを取得
Private Declare Function GetActiveWindow Lib "USER32.dll" _
    () As Long
' メニューバーを再描画
Private Declare Function DrawMenuBar Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
#End If
'***************************************************************************************************
'   ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 :CMD_CANCEL_Click
'* 機能  :キャンセル(隠しボタン)のイベント(Escキーで本イベントが発生する)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CMD_CANCEL_Click()
    '-----------------------------------------------------------------------------------------------
    ' 中断機能の使用有無はラベルのWordWrapプロパティを使う
    If LBL_Macro.WordWrap = True Then
        If MsgBox("キャンセルキーが押されました。" & _
            "ここで中断して終了しますか?", _
            vbInformation + vbYesNo, Me.Caption) = vbYes Then
            Me.Tag = 9
        End If
    End If
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_Activate
'* 機能  :フォームの表示初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Activate()
    '-----------------------------------------------------------------------------------------------
#If VBA7 Then
    Dim hWnd As LongPtr
    Dim Wnd_STYLE As LongPtr
#Else
    Dim hWnd As Long
    Dim Wnd_STYLE As Long
#End If
    ' 閉じる[×]ボタンの有効/無効はラベルのVisibleプロパティを使う
    If LBL_Macro.Visible <> True Then
        ' 閉じる[×]ボタンを無効にする
        hWnd = GetActiveWindow()
#If VBA7 Then
        Wnd_STYLE = GetWindowLongPtr(hWnd, GWL_STYLE)
        Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU)
        SetWindowLongPtr hWnd, GWL_STYLE, Wnd_STYLE
#Else
        Wnd_STYLE = GetWindowLong(hWnd, GWL_STYLE)
        Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU)
        SetWindowLong hWnd, GWL_STYLE, Wnd_STYLE
#End If
        DrawMenuBar hWnd
    End If
    Me.Tag = 0
    Fm_ProgressBar.Width = 0.01
    g_blnShowProgressBar2 = True
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_Deactivate
'* 機能  :フォーム不活性化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Deactivate()
    '-----------------------------------------------------------------------------------------------
    g_blnShowProgressBar2 = False
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_QueryClose
'* 機能  :Closeイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年08月19日
'* 作成者 :井上 治
'* 更新日 :2019年12月29日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '-----------------------------------------------------------------------------------------------
    ' 閉じる[×]ボタンは許可しない(表示されない場合は動作しない)
    If CloseMode = vbFormControlMenu Then
        ' Escキーと同様処理とする
        Call CMD_CANCEL_Click
        Cancel = True
    End If
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
|  | ←ProgressBar2.zip (43KB) |