Internals/VBCommons
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
main
VBCommons/ui/CSE_ProgressBar.frm

330 lines
8.7 KiB
Plaintext
Raw Permalink Normal View History

Initial commit
2024-06-07 20:46:40 +03:00
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CSE_ProgressBar
Caption = "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"
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 ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> - <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> 0.5%
Private Sub UserForm_Initialize()
isInterrupted_ = False
canBeInterrupted_ = False
minA_ = 0
maxA_ = 100
valueA_ = 50
progressA_ = 50
Call Init("<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>...")
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 = "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>..."
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.##") & " <20><><EFBFBD>"
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 = "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: " & TimeStr()
End Function
Private Function RepaintEx()
If Me.Visible Then
Call Me.Repaint
' BringToFront ' <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> (<28><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>)
End If
DoEvents
End Function
Reference in New Issue Copy Permalink