Notes

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "clsProgressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'***********************************************************************************************************

'フォーム
Private Const c_lFORM_WIDTH As Long = 240
Private Const c_lFORM_HEIGHT As Long = 140

'テキスト
Private Const c_lTEXT_TOP As Long = 5
Private Const c_lTEXT_LEFT As Long = 5
Private Const c_lTEXT_WIDTH As Long = 215
Private Const c_lTEXT_HEIGHT As Long = 30
'バー
Private Const c_dblZOOM_BAR As Double = 0.7
'ボタン
Private Const c_lBUTTON_WIDTH As Long = 70
'隙間
Private Const c_lPADDING_TOP As Long = 10

Private m_frmProgressBar As frmProgressBar 'ユーザーフォーム
Attribute m_frmProgressBar.VB_VarHelpID = -1
Private m_lblTextLabel As MSForms.Label '表示テキスト
Private m_lblBase As MSForms.Label 'プログレスバーの枠
Private m_lblBar As MSForms.Label 'バー本体
Private WithEvents m_btnButton As MSForms.CommandButton 'ボタン
Attribute m_btnButton.VB_VarHelpID = -1

Private m_lMaxValue As Long 'プログレスバー最大値
Private m_lBarColor As Long 'プログレスバー色
Private m_dblCurValue As Double 'プログレスバー現在値
Private m_bStopCancel As Boolean '中断可否
Private m_bEnd As Boolean

'***********************************************************************************************************

Private Sub Class_Initialize()
Call Load(frmProgressBar)
Set frmProgressBar.g_clsPB = Me
Set m_frmProgressBar = frmProgressBar
m_lMaxValue = 100
m_lBarColor = RGB(0, 0, 128)
m_dblCurValue = 0
m_bStopCancel = False
m_bEnd = False
End Sub

Private Sub Class_Terminate()
Set m_lblTextLabel = Nothing
Set m_lblBase = Nothing
Set m_lblBar = Nothing
Set m_btnButton = Nothing
Set m_frmProgressBar = Nothing
Call Unload(frmProgressBar)
End Sub

'***********************************************************************************************************

Public Property Get MaxValue() As Long
MaxValue = m_lMaxValue
End Property
Public Property Let MaxValue(ByVal lMaxValue As Long)
m_lMaxValue = lMaxValue
End Property

Public Property Let BarColor(ByVal lBarColor As Long)
m_lBarColor = lBarColor
End Property

Public Property Get StopCancel() As Boolean
StopCancel = m_bStopCancel
End Property
Public Property Let StopCancel(ByVal bStopCancel As Boolean)
m_bStopCancel = bStopCancel
End Property

Public Property Get EndProc() As Boolean
EndProc = m_bEnd
End Property

'***********************************************************************************************************

'初期化処理

Public Sub Init_Proc(Optional ByVal lFontSize As Long = 10)

'フォーム
With m_frmProgressBar
.Width = c_lFORM_WIDTH
.Height = c_lFORM_HEIGHT
End With

'表示テキスト
Set m_lblTextLabel = m_frmProgressBar.Controls.Add("Forms.Label.1", "lblTextLabel")
With m_lblTextLabel
.Top = c_lTEXT_TOP
.Left = c_lTEXT_LEFT
.Width = c_lTEXT_WIDTH
.Height = c_lTEXT_HEIGHT
.Caption = "起動中…"
.Font.Size = lFontSize
End With

'プログレスバーの枠
Set m_lblBase = m_frmProgressBar.Controls.Add("Forms.Label.1", "freBaseFrame")
With m_lblBase
.Top = m_lblTextLabel.Top + m_lblTextLabel.Height + c_lPADDING_TOP
.Left = c_lTEXT_LEFT
.Width = c_lTEXT_WIDTH
.Height = c_lTEXT_HEIGHT * c_dblZOOM_BAR
'プログレスバーの背景をへこませる
.SpecialEffect = fmSpecialEffectSunken
End With

'バー本体
Set m_lblBar = m_frmProgressBar.Controls.Add("Forms.Label.1", "lblBar")
With m_lblBar
.Top = m_lblTextLabel.Top + m_lblTextLabel.Height + c_lPADDING_TOP
.Left = c_lTEXT_LEFT
.Width = c_lTEXT_WIDTH
.Height = c_lTEXT_HEIGHT * c_dblZOOM_BAR
.BackColor = m_lBarColor
End With

'ボタン
Set m_btnButton = m_frmProgressBar.Controls.Add("Forms.CommandButton.1", "btnButton")
With m_btnButton
.Top = m_lblBar.Top + m_lblBar.Height + c_lPADDING_TOP
.Left = c_lTEXT_LEFT + c_lTEXT_WIDTH / 2 - c_lBUTTON_WIDTH / 2
.Width = c_lBUTTON_WIDTH
.Height = c_lTEXT_HEIGHT * c_dblZOOM_BAR
.Caption = "キャンセル"
End With

End Sub

'***********************************************************************************************************

'プログレスバー表示開始

Public Sub StartPB(Optional ByVal strTitle As String = "")

'中断不可なら
If m_bStopCancel = True Then
m_frmProgressBar.Enabled = False
Application.Interactive = False
Application.EnableCancelKey = xlDisabled
End If
'フォームをモードレスで表示
m_frmProgressBar.Caption = strTitle
m_lblTextLabel.Caption = strTitle
Call m_frmProgressBar.Show(vbModeless)

End Sub

'***********************************************************************************************************

'現在値表示

Public Sub SetCurrent(ByVal dblAddValue As Double, Optional ByVal strTitle As String = "", _
Optional ByVal strText As String = "")

'プログレスバー値変更
m_dblCurValue = m_dblCurValue + dblAddValue
'最大値判定
If m_dblCurValue > m_lMaxValue Then m_dblCurValue = m_lMaxValue
'現在のバーの幅計算
m_lblBar.Width = m_lblBase.Width * (m_dblCurValue / m_lMaxValue)

If strTitle <> "" Then
m_frmProgressBar.Caption = strTitle
End If
If strText <> "" Then
m_lblTextLabel.Caption = strText
End If

'再描画
'Me.Repaint 'これだと「応答なし」が出てしまう
DoEvents

End Sub

'***********************************************************************************************************

'現在値クリア

Public Sub ClearCurrent(Optional ByVal strTitle As String = "", Optional ByVal strText As String = "")

'プログレスバー値変更
m_dblCurValue = 0
'現在のバーの幅計算
m_lblBar.Width = m_lblBase.Width * (m_dblCurValue / m_lMaxValue)

If strTitle <> "" Then
m_frmProgressBar.Caption = strTitle
End If
If strText <> "" Then
m_lblTextLabel.Caption = strText
End If

'再描画
'Me.Repaint 'これだと「応答なし」が出てしまう
DoEvents

End Sub

'***********************************************************************************************************

'文字列変更

Public Sub ChangeText(Optional ByVal strTitle As String = "", Optional ByVal strText As String = "")

If strTitle <> "" Then
m_frmProgressBar.Caption = strTitle
End If
If strText <> "" Then
m_lblTextLabel.Caption = strText
End If

'再描画
'Me.Repaint 'これだと「応答なし」が出てしまう
DoEvents

End Sub

'***********************************************************************************************************

'フォーム終了

Public Sub Close_Proc()

m_bEnd = True
Call m_frmProgressBar.Hide
If Me.StopCancel = True Then
Application.Interactive = True
Application.EnableCancelKey = xlInterrupt
End If

End Sub

'***********************************************************************************************************

'ボタンクリック

Private Sub m_btnButton_Click()

Call Me.Close_Proc

End Sub

'***********************************************************************************************************