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