'***************************************************************************************************
' プログレスバーをコントロールするクラス(テスト用標準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) |