Bob Phillips said:
will you publish to the world? I
did a stacked progress bar recently, on a form, but the status bar would be
nice (didn't even think of that).
All the usual disclaimers apply (“...quite a while ago...not well
maintained... hard-coded assumptions...would do it differently now...â€):
'---<Example usage>---
Private Sub TestBars()
Dim bar1 As CExcelProgressbar
Set bar1 = New CExcelProgressbar
Dim bar2 As CExcelProgressbar
Set bar2 = New CExcelProgressbar
bar1.Init _
"Doing stuff", , , _
RGB(125, 195, 195), , True, _
wpBorderStyleNone, wpAppearance3D
bar2.Init _
, 300, , _
RGB(204, 134, 0), , False, _
wpBorderStyleFixedSingle, wpAppearanceFlat
Dim i As Long
For i = 1 To 1000000
bar1.Update i / 10000
Next
For i = 1 To 1000000
bar2.Update i / 10000
Next
For i = 1 To 1000000
Next
Set bar1 = Nothing
Set bar2 = Nothing
End Sub
'---</Example usage>---
'---<class: CExcelProgressbar>---
Option Explicit
Private Declare Function GetDC Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 _
Lib "gdi32" Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As Size) As Long
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx _
Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetClientRect _
Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Approx equal to Excel's when saving
Private Const WIDTH_DEFAULT As Long = 190
Private Const INDENT_DEFAULT As Long = 1
Private m_WindowProgressbar As CWindowProgressbar
Private m_blnInitialized As Boolean
Public Function Init( _
Optional ByVal InitialMessage As String, _
Optional ByVal Indent As Long, _
Optional ByVal Width As Long = WIDTH_DEFAULT, _
Optional ByVal ForeColor As Variant = wpColorUseDefault, _
Optional ByVal BackColor As Variant = wpColorUseDefault, _
Optional ByVal SmoothBackground As Boolean = False, _
Optional ByVal BorderStyle As wpBorderStyleEnum =
wpBorderStyleFixedSingle, _
Optional ByVal Appearance As wpAppearanceEnum = wpAppearanceFlat _
) As Boolean
With Excel.Application
' Get hWnd for Excel's statusbar
Dim hThis As Long
hThis = FindWindow(vbNullString, .Caption)
Dim hExcel4 As Long
hExcel4 = FindWindowEx(hThis, 0, "EXCEL4", vbNullString)
If hExcel4 = 0 Then
hExcel4 = FindWindowEx(hThis, 0&, "EXCEL2", vbNullString)
End If
' Width
Dim lngWidth As Long
If Width <= 0 Then
lngWidth = WIDTH_DEFAULT
Else
lngWidth = Width
End If
' Indent
Dim lngIndent As Long
lngIndent = Indent
If lngIndent < 0 Then
lngIndent = 0
End If
If lngIndent = 0 Then
If Len(InitialMessage) = 0 Then
lngIndent = INDENT_DEFAULT
Else
' No explicit indent value so indent to
' fit initial message text
Dim hdc As Long
Dim TextMetricsStruct As TEXTMETRIC
Dim TextSize As Size
hdc = GetDC(hExcel4)
GetTextExtentPoint32 _
hdc, InitialMessage, Len(InitialMessage), _
TextSize
' Add margin between text and progressbar
lngIndent = lngIndent + TextSize.cx + 12
ReleaseDC hExcel4, hdc
End If
End If
' Get rect for Excel's statusbar
Dim rExcel4 As RECT
GetClientRect hExcel4, rExcel4
' Position
Dim lngHeight As Long
Dim lngTop As Long
lngHeight = rExcel4.Bottom - rExcel4.Top - 8
lngTop = rExcel4.Top + 5
' Show message in Excel's statusbar
If Len(InitialMessage) > 0 Then
.StatusBar = InitialMessage
End If
End With
Set m_WindowProgressbar = New CWindowProgressbar
Init = m_WindowProgressbar.Init( _
hExcel4, lngIndent, lngTop, lngWidth, lngHeight, _
ForeColor, BackColor, SmoothBackground, _
BorderStyle, Appearance)
m_blnInitialized = True
End Function
Public Function Update( _
Optional ByVal ProgressPercentage As Long = 100, _
Optional ByVal MessageText As Variant, _
Optional ByVal ForeColor As Variant = wpColorUseExisting _
) As Boolean
If Not m_blnInitialized Then
Init MessageText, , , ForeColor
End If
If Not IsMissing(MessageText) Then
Excel.Application.StatusBar = MessageText
End If
Update = m_WindowProgressbar.Update( _
ProgressPercentage, ForeColor)
End Function
Private Sub Class_Terminate()
Excel.Application.StatusBar = False
End Sub
'---</class: CExcelProgressbar>---
'---<class: CUserformProgressbar>---
Option Explicit
' --- <Win32 API declarations> ---
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" ( _
ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
' --- </Win32 API declarations> ---
Private Const WIDTH_DEFAULT As Long = 93
Private Const HEIGHT_DEFAULT As Long = 10
Private m_WindowProgressbar As CWindowProgressbar
Public Function Init( _
Optional ByVal UserformInstance As Object, _
Optional ByVal Left As Long, _
Optional ByVal Top As Long, _
Optional ByVal Width As Long = WIDTH_DEFAULT, _
Optional ByVal Height As Long = HEIGHT_DEFAULT, _
Optional ByVal ForeColor As Variant = wpColorUseDefault, _
Optional ByVal BackColor As Variant = wpColorUseDefault, _
Optional ByVal SmoothBackground As Boolean = False, _
Optional ByVal BorderStyle As wpBorderStyleEnum =
wpBorderStyleFixedSingle, _
Optional ByVal Appearance As wpAppearanceEnum = wpAppearanceFlat _
) As Boolean
Dim oUserform As MSForms.UserForm
On Error Resume Next
Set oUserform = UserformInstance
On Error GoTo 0
If oUserform Is Nothing Then
Exit Function
End If
Set m_WindowProgressbar = New CWindowProgressbar
Init = m_WindowProgressbar.Init(hWnd(UserformInstance), _
Left / PointsPerPixelX, Top / PointsPerPixelY, _
Width / PointsPerPixelX, Height / PointsPerPixelY, _
ForeColor, BackColor, SmoothBackground, BorderStyle, Appearance)
End Function
Public Function Update( _
Optional ByVal ProgressPercentage As Long = 100, _
Optional ByVal ForeColor As Variant = wpColorUseExisting _
) As Boolean
m_WindowProgressbar.Update ProgressPercentage, ForeColor
End Function
Private Property Get hWnd(ByVal UserformInstance As Object) As Long
hWnd = FindWindow("ThunderDFrame", UserformInstance.Caption)
End Property
Private Property Get PointsPerPixelX() As Double
Dim hdc As Long
hdc = GetDC(0)
PointsPerPixelX = 72 / GetDeviceCaps(hdc, LOGPIXELSX)
ReleaseDC 0, hdc
End Property
Private Property Get PointsPerPixelY() As Double
Dim hdc As Long
hdc = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hdc, LOGPIXELSY)
ReleaseDC 0, hdc
End Property
'---</class: CUserformProgressbar>---
'---<class: CWindowProgressbar>---
Option Explicit
Private Declare Function SetWindowPos _
Lib "user32" (ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As
Long
Private Declare Function CreateWindowEx _
Lib "user32" Alias "CreateWindowExA" _
(ByVal lngStyleEx As Long, ByVal lpClassName As String, _
ByVal lpWindowName As String, ByVal lngStyle As Long, _
ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hWndParent As Long, _
ByVal hMenu As Long, ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function DestroyWindow _
Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage _
Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClientRect _
Lib "user32" _
(ByVal hWnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_BORDER As Long = &H800000
Private Const WM_USER As Long = &H400
Private Const PBM_SETBARCOLOR As Long = WM_USER + 9
Private Const PBM_SETBKCOLOR As Long = &H2001
Private Const PBM_SETPOS As Long = WM_USER + 2
Private Const PBS_SMOOTH As Long = 1
Private Const PBS_MARQUEE As Long = 8
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_FRAMECHANGED As Long = &H20
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const SWP_NOREPOSITION As Long = SWP_NOOWNERZORDER
Private Const SWP_NOZORDER As Long = &H4
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WS_EX_WINDOWEDGE As Long = &H100&
Private Const WS_EX_STATICEDGE As Long = &H20000
Private Const GWL_STYLE As Long = (-16)
Private Const GWL_EXSTYLE As Long = (-20)
Private Const PROGRESS_CLASS_NAME As String = _
"msctls_progress32"
Public Enum wpColorEnum
wpColorUseDefault = -3
wpColorUseExisting = -2
End Enum
Public Enum wpBorderStyleEnum
wpBorderStyleNone = 0
wpBorderStyleFixedSingle = 1
End Enum
Public Enum wpAppearanceEnum
wpAppearanceFlat = 0
wpAppearance3D = 1
End Enum
' Retain progressbar hWnd
Private m_hProgress As Long
' Approx equal to Excel's when saving
Private Const WIDTH_DEFAULT As Long = 93
Private Const HEIGHT_DEFAULT As Long = 10
' Default bar to blue
Private Const COLOR_DEFAULT_FORE As Long = 8388608
'' Default backcolor to gray
'Private Const COLOR_DEFAULT_BACK As Long = 13160660
Private m_lngProgressPercentage As Long
Public Function Init( _
Optional ByVal hWnd As Long, _
Optional ByVal Left As Long, _
Optional ByVal Top As Long, _
Optional ByVal Width As Long = WIDTH_DEFAULT, _
Optional ByVal Height As Long = HEIGHT_DEFAULT, _
Optional ByVal ForeColor As Variant = wpColorUseDefault, _
Optional ByVal BackColor As Variant = wpColorUseDefault, _
Optional ByVal SmoothBackground As Boolean = False, _
Optional ByVal BorderStyle As wpBorderStyleEnum =
wpBorderStyleFixedSingle, _
Optional ByVal Appearance As wpAppearanceEnum = wpAppearanceFlat _
) As Boolean
' Remove existing progressbar
If m_hProgress <> 0 Then
Remove
End If
' Width
If Width <= 0 Then
Width = WIDTH_DEFAULT
End If
' Height
If Height < 0 Then
Height = HEIGHT_DEFAULT
End If
' Get rect for window
Dim rWnd As RECT
GetClientRect hWnd, rWnd
' Left
Dim lngLeft As Long
If Left < 0 Then
lngLeft = rWnd.Right + Left
Else
lngLeft = rWnd.Left + Left
End If
' Top
Dim lngTop As Long
If Top < 0 Then
lngTop = rWnd.Bottom + Top
Else
lngTop = rWnd.Top + Top
End If
' Progressbar's style
Dim lngStyleProgress As Long
lngStyleProgress = WS_VISIBLE Or WS_CHILD
If SmoothBackground Then
lngStyleProgress = lngStyleProgress Or PBS_SMOOTH
Else
lngStyleProgress = lngStyleProgress Or PBS_MARQUEE
End If
' Create progressbar window
m_hProgress = _
CreateWindowEx(0, PROGRESS_CLASS_NAME, _
vbNullString, lngStyleProgress, lngLeft, _
lngTop, Width, Height, hWnd, 0, 0, 0)
' Change progressbar's appearance/border
Dim lngStyle As Long
Dim lngStyleEx As Long
Dim lngFrameChangedOnly As Long
lngStyle = GetWindowLong(m_hProgress, GWL_STYLE)
lngStyleEx = GetWindowLong(m_hProgress, GWL_EXSTYLE)
Select Case BorderStyle
Case wpBorderStyleNone
Select Case Appearance
Case wpAppearanceFlat
lngStyle = lngStyle And Not WS_BORDER
lngStyleEx = lngStyleEx Or WS_EX_WINDOWEDGE
lngStyleEx = lngStyleEx And Not WS_EX_STATICEDGE
lngStyleEx = lngStyleEx And Not WS_EX_CLIENTEDGE
Case wpAppearance3D
lngStyle = lngStyle And Not WS_BORDER
lngStyleEx = lngStyleEx And Not WS_EX_WINDOWEDGE
lngStyleEx = lngStyleEx Or WS_EX_STATICEDGE
lngStyleEx = lngStyleEx And Not WS_EX_CLIENTEDGE
End Select
Case wpBorderStyleFixedSingle
Select Case Appearance
Case wpAppearanceFlat
lngStyle = lngStyle Or WS_BORDER
lngStyleEx = lngStyleEx And Not WS_EX_WINDOWEDGE
lngStyleEx = lngStyleEx And Not WS_EX_STATICEDGE
lngStyleEx = lngStyleEx And Not WS_EX_CLIENTEDGE
Case wpAppearance3D
lngStyle = lngStyle And Not WS_BORDER
lngStyleEx = lngStyleEx And Not WS_EX_WINDOWEDGE
lngStyleEx = lngStyleEx And Not WS_EX_STATICEDGE
lngStyleEx = lngStyleEx Or WS_EX_CLIENTEDGE
End Select
End Select
lngFrameChangedOnly = _
SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOREPOSITION _
Or SWP_NOZORDER Or SWP_FRAMECHANGED
SetWindowLong m_hProgress, GWL_STYLE, lngStyle
SetWindowLong m_hProgress, GWL_EXSTYLE, lngStyleEx
SetWindowPos _
m_hProgress, 0, 0, 0, 0, 0, lngFrameChangedOnly
' ForeColor
Dim lngForeColor As Long
lngForeColor = COLOR_DEFAULT_FORE
If Not IsEmpty(ForeColor) Then
If ForeColor <> wpColorUseDefault Then
On Error Resume Next
lngForeColor = CLng(ForeColor)
On Error GoTo 0
End If
End If
If lngForeColor < RGB(0, 0, 0) _
Or lngForeColor > RGB(255, 255, 255) Then
lngForeColor = COLOR_DEFAULT_FORE
End If
SendMessage _
m_hProgress, PBM_SETBARCOLOR, 1, _
ByVal lngForeColor
' BackColor
If BackColor <> wpColorUseDefault Then
Dim lngBackColor As Long
If Not IsEmpty(BackColor) Then
On Error Resume Next
lngBackColor = CLng(BackColor)
On Error GoTo 0
End If
If lngBackColor >= RGB(0, 0, 0) _
And lngBackColor <= RGB(255, 255, 255) Then
SendMessage _
m_hProgress, PBM_SETBKCOLOR, 1, _
ByVal lngBackColor
End If
End If
DoEvents
Init = True
End Function
Public Function Update( _
Optional ByVal ProgressPercentage As Long = 100, _
Optional ByVal ForeColor As Variant = wpColorUseExisting _
) As Boolean
If m_hProgress = 0 Then
Exit Function
End If
If m_lngProgressPercentage <> ProgressPercentage Then
m_lngProgressPercentage = ProgressPercentage
SendMessage _
m_hProgress, PBM_SETPOS, _
ProgressPercentage, 0
Update = True
End If
' ForeColor
Dim lngForeColor As Long
If Not IsMissing(ForeColor) Then
If Not IsEmpty(ForeColor) Then
If ForeColor <> wpColorUseExisting Then
lngForeColor = wpColorUseDefault
On Error Resume Next
lngForeColor = CLng(ForeColor)
On Error GoTo 0
If lngForeColor < RGB(0, 0, 0) _
Or lngForeColor > RGB(255, 255, 255) Then
lngForeColor = COLOR_DEFAULT_FORE
End If
SendMessage _
m_hProgress, PBM_SETBARCOLOR, 1, _
ByVal lngForeColor
Update = True
End If
End If
End If
End Function
Private Sub Class_Terminate()
On Error Resume Next
Remove
DoEvents
End Sub
Private Function Remove() As Boolean
DestroyWindow m_hProgress
m_hProgress = 0
Remove = True
End Function
Public Property Get ProgressPercentage() As Long
ProgressPercentage = m_lngProgressPercentage
End Property
'---</class: CWindowProgressbar>---
Jamie.
--
