Notes![what is notes.io? What is notes.io?](/theme/images/whatisnotesio.png)
![]() ![]() Notes - notes.io |
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
'***********************************************************************************************************
![]() |
Notes.io is a web-based application for taking notes. You can take your notes and share with others people. If you like taking long notes, notes.io is designed for you. To date, over 8,000,000,000 notes created and continuing...
With notes.io;
- * You can take a note from anywhere and any device with internet connection.
- * You can share the notes in social platforms (YouTube, Facebook, Twitter, instagram etc.).
- * You can quickly share your contents without website, blog and e-mail.
- * You don't need to create any Account to share a note. As you wish you can use quick, easy and best shortened notes with sms, websites, e-mail, or messaging services (WhatsApp, iMessage, Telegram, Signal).
- * Notes.io has fabulous infrastructure design for a short link and allows you to share the note as an easy and understandable link.
Fast: Notes.io is built for speed and performance. You can take a notes quickly and browse your archive.
Easy: Notes.io doesn’t require installation. Just write and share note!
Short: Notes.io’s url just 8 character. You’ll get shorten link of your note when you want to share. (Ex: notes.io/q )
Free: Notes.io works for 12 years and has been free since the day it was started.
You immediately create your first note and start sharing with the ones you wish. If you want to contact us, you can use the following communication channels;
Email: [email protected]
Twitter: http://twitter.com/notesio
Instagram: http://instagram.com/notes.io
Facebook: http://facebook.com/notesio
Regards;
Notes.io Team