330 lines
8.7 KiB
Plaintext
330 lines
8.7 KiB
Plaintext
VERSION 5.00
|
|
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ProgressBar
|
|
Caption = "Âûïîëíåíèå ïðîöåññà"
|
|
ClientHeight = 2850
|
|
ClientLeft = 45
|
|
ClientTop = 330
|
|
ClientWidth = 5280
|
|
OleObjectBlob = "CSE_ProgressBar.frx":0000
|
|
ShowModal = 0 'False
|
|
StartUpPosition = 2 'CenterScreen
|
|
End
|
|
Attribute VB_Name = "CSE_ProgressBar"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = False
|
|
Attribute VB_PredeclaredId = True
|
|
Attribute VB_Exposed = False
|
|
' =========== Progress Bar ================
|
|
' Shared module version: 20210827
|
|
' Tested in:
|
|
' Depends on:
|
|
' Required reference:
|
|
Option Explicit
|
|
|
|
Private thisWindow_&
|
|
|
|
Private isInterrupted_ As Boolean
|
|
Private canBeInterrupted_ As Boolean
|
|
|
|
Private minA_&
|
|
Private maxA_&
|
|
Private valueA_&
|
|
Private progressA_ As Double
|
|
|
|
Private minB_&
|
|
Private maxB_&
|
|
Private valueB_&
|
|
Private progressB_ As Double
|
|
|
|
Private tStart_&
|
|
|
|
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
|
|
|
|
'Windows API calls to remove the [x] from the top-right of the form
|
|
Private Declare PtrSafe Function FindWindow Lib "user32" _
|
|
Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
|
|
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
|
|
Alias "GetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long) As Long
|
|
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
|
|
Alias "SetWindowLongA" (ByVal nHwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
|
|
|
|
'Windows API calls to bring the progress bar form to the front of other modeless forms
|
|
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
|
|
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, ByRef lpdwProcessId As Long) As Long
|
|
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal nHwnd As Long) As Long
|
|
|
|
Private Const UDATE_RATE = 0.005 ' ×àñòîòà îáíîâëåíèÿ - êàæäûé 0.5%
|
|
|
|
Private Sub UserForm_Initialize()
|
|
isInterrupted_ = False
|
|
canBeInterrupted_ = False
|
|
|
|
minA_ = 0
|
|
maxA_ = 100
|
|
valueA_ = 50
|
|
progressA_ = 50
|
|
|
|
Call Init("Çàãðóçêà...")
|
|
If Application.Name <> "Microsoft Visio" Then _
|
|
Call PositionInMiddle
|
|
Call RemoveCloseButton
|
|
End Sub
|
|
|
|
Public Function Init(sTitle$, _
|
|
Optional sHeader$ = vbNullString, _
|
|
Optional minVal& = 0, _
|
|
Optional maxVal& = 100, _
|
|
Optional curVal& = 0, _
|
|
Optional canInterrupt As Boolean = False)
|
|
canBeInterrupted_ = canInterrupt
|
|
btnInterrupt.Visible = canInterrupt
|
|
isInterrupted_ = False
|
|
|
|
If thisWindow_ = 0 Then
|
|
Me.Caption = "VBAProgressBar"
|
|
thisWindow_ = FindWindow(vbNullString, Me.Caption)
|
|
End If
|
|
|
|
tStart_ = GetTickCount()
|
|
|
|
minA_ = minVal
|
|
maxA_ = maxVal
|
|
|
|
minB_ = 0
|
|
maxB_ = 100
|
|
valueB_ = 0
|
|
|
|
Call EnableSecondBar(False)
|
|
Me.Title = sTitle
|
|
Me.HeaderLbl.Caption = sHeader
|
|
Me.DescriptionTB.Text = vbNullString
|
|
|
|
Call SetAInternal(curVal, bForceUpdate:=True)
|
|
End Function
|
|
|
|
Public Function InitSecondBar(Optional minVal& = 0, Optional maxVal& = 100, Optional curVal& = 0)
|
|
Call EnableSecondBar(True)
|
|
minB_ = minVal
|
|
maxB_ = maxVal
|
|
Call SetBInternal(curVal, bForceUpdate:=True)
|
|
End Function
|
|
|
|
Public Function ShowModeless()
|
|
Call UpdateBar
|
|
Call Me.Show(vbModeless)
|
|
End Function
|
|
|
|
Private Sub btnInterrupt_Click()
|
|
HeaderLbl.Caption = "Èíèöèèðîâàíà îòìåíà, îæèäàéòå..."
|
|
isInterrupted_ = True
|
|
|
|
btnInterrupt.Enabled = False
|
|
Call RepaintEx
|
|
End Sub
|
|
|
|
Private Sub UserForm_QueryClose(ByRef nCancelCode As Integer, ByRef nCloseMode As Integer)
|
|
If nCloseMode = vbFormControlMenu And canBeInterrupted_ Then _
|
|
nCancelCode = True
|
|
End Sub
|
|
|
|
' ====== Access =====
|
|
Public Property Get Interrupted() As Boolean
|
|
Interrupted = isInterrupted_
|
|
End Property
|
|
|
|
Public Property Get Time() As Double
|
|
Time = GetTickCount() - tStart_
|
|
End Property
|
|
|
|
Public Property Get TimeStr() As String
|
|
TimeStr = Format(Time / 1000, "# ##0.##") & " ñåê"
|
|
End Property
|
|
|
|
Public Property Get Title() As String
|
|
Title = Me.Caption
|
|
End Property
|
|
|
|
Public Property Get Description() As String
|
|
Description = DescriptionTB.Text
|
|
End Property
|
|
|
|
Public Property Get Header() As String
|
|
Header = HeaderLbl.Caption
|
|
End Property
|
|
|
|
Public Property Get SecondBarEnabled() As Boolean
|
|
SecondBarEnabled = FrameSecBar.Visible
|
|
End Property
|
|
|
|
Public Property Get ValueA() As Long
|
|
ValueA = valueA_
|
|
End Property
|
|
|
|
Public Property Get MinA() As Long
|
|
MinA = minA_
|
|
End Property
|
|
|
|
Public Property Get MaxA() As Long
|
|
MaxA = maxA_
|
|
End Property
|
|
|
|
Public Property Get ProgressA() As Double
|
|
If maxA_ = minA_ Then
|
|
ProgressA = 100
|
|
Else
|
|
ProgressA = VBA.Abs((valueA_ - minA_) / (maxA_ - minA_))
|
|
End If
|
|
End Property
|
|
|
|
Public Property Get ValueB() As Long
|
|
ValueB = valueB_
|
|
End Property
|
|
|
|
Public Property Get MinB() As Long
|
|
MinB = minB_
|
|
End Property
|
|
|
|
Public Property Get MaxB() As Long
|
|
MaxB = maxB_
|
|
End Property
|
|
|
|
Public Property Get ProgressB() As Double
|
|
If maxB_ = minB_ Then
|
|
ProgressB = 100
|
|
Else
|
|
ProgressB = VBA.Abs((valueB_ - minB_) / (maxB_ - minB_))
|
|
End If
|
|
End Property
|
|
|
|
' ===== Modify =====
|
|
Public Property Let Title(ByVal newVal$)
|
|
Me.Caption = newVal
|
|
Call RemoveCloseButton
|
|
End Property
|
|
|
|
Public Property Let Description(ByVal newVal$)
|
|
DescriptionTB.Text = newVal
|
|
Call RepaintEx
|
|
End Property
|
|
|
|
Public Property Let Header(ByVal newVal$)
|
|
HeaderLbl.Caption = newVal
|
|
Call RepaintEx
|
|
End Property
|
|
|
|
' ====== Actions ===
|
|
Public Function IncrementA(Optional delta& = 1)
|
|
If Me.Visible Then _
|
|
Call SetAInternal(valueA_ + delta, bForceUpdate:=False)
|
|
End Function
|
|
|
|
Public Function IncrementB(Optional delta& = 1)
|
|
If Me.Visible Then _
|
|
Call SetBInternal(valueB_ + delta, bForceUpdate:=False)
|
|
End Function
|
|
|
|
Public Function HideSecondBar()
|
|
Call EnableSecondBar(False)
|
|
End Function
|
|
|
|
Public Function SetA(ByVal newVal&, Optional bForceUpdate As Boolean = False)
|
|
If Me.Visible Then _
|
|
Call SetAInternal(newVal, bForceUpdate)
|
|
End Function
|
|
|
|
Public Function SetB(ByVal newVal&, Optional bForceUpdate As Boolean = False)
|
|
If Me.Visible Then _
|
|
Call SetBInternal(newVal, bForceUpdate)
|
|
End Function
|
|
|
|
' =======
|
|
Private Function EnableSecondBar(bEnable As Boolean)
|
|
FrameSecBar.Visible = bEnable
|
|
Call RepaintEx
|
|
End Function
|
|
|
|
Private Function PositionInMiddle()
|
|
Dim nTopOffset&: nTopOffset = (Application.UsableHeight / 2) - (Me.Height / 2)
|
|
Dim nLeftOffset&: nLeftOffset = (Application.UsableWidth / 2) - (Me.Width / 2)
|
|
|
|
Me.StartUpPosition = 0
|
|
Me.Top = Application.Top + IIf(nTopOffset > 0, nTopOffset, 0)
|
|
Me.Left = Application.Left + IIf(nLeftOffset > 0, nLeftOffset, 0)
|
|
End Function
|
|
|
|
Private Function SetAInternal(ByVal newVal&, bForceUpdate As Boolean)
|
|
valueA_ = newVal
|
|
If valueA_ > maxA_ Then _
|
|
valueA_ = maxA_
|
|
If valueA_ < minA_ Then _
|
|
valueA_ = minA_
|
|
Call SetProgressA(Me.ProgressA, bForceUpdate)
|
|
End Function
|
|
|
|
Private Function SetBInternal(ByVal newVal&, bForceUpdate As Boolean)
|
|
valueB_ = newVal
|
|
If valueB_ > maxB_ Then _
|
|
valueB_ = maxB_
|
|
If valueB_ < minB_ Then _
|
|
valueB_ = minB_
|
|
Call SetProgressB(Me.ProgressB, bForceUpdate)
|
|
End Function
|
|
|
|
Private Function SetProgressA(newProgress As Double, bForceUpdate As Boolean)
|
|
If Not bForceUpdate And Abs(newProgress - progressA_) < UDATE_RATE Then _
|
|
Exit Function
|
|
|
|
progressA_ = newProgress
|
|
Call UpdateTime
|
|
Call UpdateBar
|
|
Call RepaintEx
|
|
End Function
|
|
|
|
Private Function SetProgressB(newProgress As Double, bForceUpdate)
|
|
If Not bForceUpdate And Abs(newProgress - progressB_) < UDATE_RATE Then _
|
|
Exit Function
|
|
|
|
progressB_ = newProgress
|
|
Call UpdateTime
|
|
Call UpdateBar
|
|
Call RepaintEx
|
|
End Function
|
|
|
|
Private Function UpdateBar()
|
|
fraInside.Width = VBA.Int(lblBack.Width * progressA_)
|
|
lblSecBar.Width = VBA.Int(FrameSecBar.Width * progressB_)
|
|
|
|
lblBack.Caption = Format(progressA_, "0%")
|
|
lblFront.Caption = Format(progressA_, "0%")
|
|
End Function
|
|
|
|
Private Function RemoveCloseButton()
|
|
Const WS_SYSMENU& = &H80000
|
|
Const GWL_STYLE& = (-16)
|
|
Dim lStyle&: lStyle = GetWindowLong(thisWindow_, GWL_STYLE)
|
|
If lStyle And WS_SYSMENU > 0 Then _
|
|
Call SetWindowLong(thisWindow_, GWL_STYLE, (lStyle And Not WS_SYSMENU))
|
|
End Function
|
|
|
|
Private Function BringToFront()
|
|
Dim lFocusThread&: lFocusThread = GetWindowThreadProcessId(GetForegroundWindow(), 0)
|
|
Dim lThisThread&: lThisThread = GetWindowThreadProcessId(thisWindow_, 0)
|
|
If lFocusThread = lThisThread Then
|
|
Call SetForegroundWindow(thisWindow_)
|
|
Else
|
|
DoEvents
|
|
End If
|
|
End Function
|
|
|
|
Private Function UpdateTime()
|
|
TimeLabel.Caption = "Äëèòåëüíîñòü: " & TimeStr()
|
|
End Function
|
|
|
|
Private Function RepaintEx()
|
|
If Me.Visible Then
|
|
Call Me.Repaint
|
|
' BringToFront ' Ðàñêîììåíòèðîâàòü, ÷òîáû îêíî ñàìî âñïëûâàëî ïðè êàæäîì îáíîâëåíèè (óæàñíî áåñèò â ôîíîâîì ðåæèìå)
|
|
End If
|
|
DoEvents
|
|
End Function
|