There was a Tweet from @ExcelEasy earlier this week, that linked to this article, to which I replied with a little challenge:
@ExcelEasy well done! #Challenge: make a more #OOP one without using the form's default/global instance! #becausewhynot
Of course I wouldn't just leave it at that, so here's my own implementation:
UserForm: ProgressView
The form itself isn't responsible for anything other than updating itself and notifying the ProgressIndicator
when it's ready to start reporting progress, or when the user clicked the red "X" button to cancel the action in progress.
I kept it simple, but flexible enough to allow the ProgressIndicator
and its client code change its caption and label as needed.
Option Explicit
Private Const PROGRESSBAR_MAXWIDTH As Integer = 224
Public Event Activated()
Public Event Cancelled()
Private Sub UserForm_Activate()
ProgressBar.Width = 0 ' it's set to 10 to be visible at design-time
RaiseEvent Activated
End Sub
Public Sub Update(ByVal percentValue As Single, Optional ByVal labelValue As String, Optional ByVal captionValue As String)
If labelValue <> vbNullString Then
ProgressLabel.Caption = labelValue
End If
If captionValue <> vbNullString Then
Me.Caption = captionValue
End If
ProgressBar.Width = percentValue * PROGRESSBAR_MAXWIDTH
DoEvents
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
RaiseEvent Cancelled
End If
End Sub
Class: ProgressIndicator
That's where the logic is. I've set it up with reasonable defaults, so that it's usable with minimal configuration. I'm including the actual text file, because this class (and the form) is meant to be defined in an Excel add-in (.xlam), so that it's available to every VBA project; as such, it's Public, not creatable, which makes it impossible to instantiate from client code - that's why I've set the PredeclaredId
attribute to True
and included a factory method:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ProgressIndicator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const DEFAULT_CAPTION As String = "Progress"
Private Const DEFAULT_LABEL As String = "Please wait..."
Private Const ERR_NOT_INITIALIZED As String = "ProgressIndicator is not initialized."
Private Const ERR_PROC_NOT_FOUND As String = "Specified macro or object member was not found."
Private Const ERR_OPERATION_CANCELLED As String = "Operation was cancelled by the user."
Public Enum ProgressIndicatorError
Error_NotInitialized = vbObjectError + 1001
Error_ProcedureNotFound
Error_OperationCancelled
End Enum
Private Type TProgressIndicator
procedure As String
instance As Object
sleepDelay As Long
End Type
Private this As TProgressIndicator
Private WithEvents view As ProgressView
Attribute view.VB_VarHelpID = -1
Private Sub Class_Initialize()
Set view = New ProgressView
view.Caption = DEFAULT_CAPTION
view.ProgressLabel = DEFAULT_LABEL
End Sub
Private Sub Class_Terminate()
Set view = Nothing
Set this.instance = Nothing
End Sub
Private Function QualifyMacroName(ByVal book As Workbook, ByVal procedure As String) As String
QualifyMacroName = "'" & book.FullName & "'!" & procedure
End Function
Public Function Create(ByVal procedure As String, Optional instance As Object = Nothing, Optional ByVal initialLabelValue As String, Optional ByVal initialCaptionValue As String, Optional ByVal completedSleepMilliseconds As Long = 1000) As ProgressIndicator
Dim result As New ProgressIndicator
result.SleepMilliseconds = completedSleepMilliseconds
If Not instance Is Nothing Then
Set result.OwnerInstance = instance
ElseIf Not Framework.Strings.Contains(procedure, "'!") Then
procedure = QualifyMacroName(Application.ActiveWorkbook, procedure)
End If
result.ProcedureName = procedure
If initialLabelValue <> vbNullString Then
result.ProgressView.ProgressLabel = initialLabelValue
End If
If initialCaptionValue <> vbNullString Then
result.ProgressView.Caption = initialCaptionValue
End If
Set Create = result
End Function
Friend Property Get ProgressView() As ProgressView
Set ProgressView = view
End Property
Friend Property Get ProcedureName() As String
ProcedureName = this.procedure
End Property
Friend Property Let ProcedureName(ByVal value As String)
this.procedure = value
End Property
Friend Property Get OwnerInstance() As Object
Set OwnerInstance = this.instance
End Property
Friend Property Set OwnerInstance(ByVal value As Object)
Set this.instance = value
End Property
Friend Property Get SleepMilliseconds() As Long
SleepMilliseconds = this.sleepDelay
End Property
Friend Property Let SleepMilliseconds(ByVal value As Long)
this.sleepDelay = value
End Property
Public Sub Execute()
view.Show vbModal
End Sub
Public Sub Update(ByVal percentValue As Single, Optional ByVal labelValue As String, Optional ByVal captionValue As String)
On Error GoTo CleanFail
ThrowIfNotInitialized
ValidatePercentValue percentValue
view.Update percentValue, labelValue
CleanExit:
If percentValue = 1 Then Sleep this.sleepDelay
Exit Sub
CleanFail:
MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
Resume CleanExit
End Sub
Public Sub UpdatePercent(ByVal percentValue As Single, Optional ByVal captionValue As String)
ValidatePercentValue percentValue
Update percentValue, Format(percentValue, "0.0% Completed")
End Sub
Private Sub ValidatePercentValue(ByRef percentValue As Single)
If percentValue > 1 Then
percentValue = percentValue / 100
End If
End Sub
Private Sub ThrowIfNotInitialized()
If this.procedure = vbNullString Then
Err.Raise ProgressIndicatorError.Error_NotInitialized, TypeName(Me), ERR_NOT_INITIALIZED
End If
End Sub
Private Sub view_Activated()
On Error GoTo CleanFail
ThrowIfNotInitialized
If Not this.instance Is Nothing Then
ExecuteInstanceMethod
Else
ExecuteMacro
End If
CleanExit:
view.Hide
Exit Sub
CleanFail:
MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
Resume CleanExit
End Sub
Private Sub ExecuteMacro()
On Error GoTo CleanFail
Application.Run this.procedure, Me
CleanExit:
Exit Sub
CleanFail:
If Err.Number = 438 Then
Err.Raise ProgressIndicatorError.Error_ProcedureNotFound, TypeName(Me), ERR_PROC_NOT_FOUND
Else
Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext
End If
Resume CleanExit
End Sub
Private Sub ExecuteInstanceMethod()
On Error GoTo CleanFail
Dim parameter As ProgressIndicator
Set parameter = Me 'Me cannot be passed to CallByName directly
CallByName this.instance, this.procedure, VbMethod, parameter
CleanExit:
Exit Sub
CleanFail:
If Err.Number = 438 Then
Err.Raise ProgressIndicatorError.Error_ProcedureNotFound, TypeName(Me), ERR_PROC_NOT_FOUND
Else
Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext
End If
Resume CleanExit
End Sub
Private Sub view_Cancelled()
'this error isn't trappable, but not raising it wouldn't cancel anything:
Err.Raise ProgressIndicatorError.Error_OperationCancelled, TypeName(Me), ERR_OPERATION_CANCELLED
End Sub
One thing I don't like, is that UpdatePercent
will validate the percentValue
parameter twice. Another thing I don't like, is that ValidatePercentValue
has side-effects and should really be a Function
that returns a Boolean
... or it should have a different name, but I'm not sure what.
Client Code
The client code is in two parts; the first is responsible for instantiating the ProgressIndicator
and specifying what procedure will do the work. Typically that would be a parameterless macro procedure attached to an ActiveX or Forms button on a worksheet:
Public Sub DoSomething()
With ProgressIndicator.Create("DoWork")
.Execute
End With
End Sub
The "DoWork" procedure can be any Public Sub
located in a standard or class module, taking a ProgressIndicator
parameter - here it's a macro procedure in a standard module. I could have specified an instance
parameter to make it work off a member procedure, too.
All that procedure needs to care about, is the work it's responsible for; when it needs to report progress, it can do so by calling the Update
or UpdatePercent
method on the progress
parameter:
Public Sub DoWork(ByVal progress As ProgressIndicator)
Dim i As Long
For i = 1 To 1000
Cells(1, 1) = i
progress.UpdatePercent i / 1000
Next
End Sub
Any oversight?
I'm using a Framework.Strings.Contains
function in the ProgressIndicator
class - as I said this code lives in an Excel add-in that has plenty of other useful tools; here's the function in question, for completeness:
Public Function Contains(ByVal string_source As String, ByVal find_text As String, Optional ByVal caseSensitive As Boolean = False) As Boolean
Dim compareMethod As VbCompareMethod
If caseSensitive Then
compareMethod = vbBinaryCompare
Else
compareMethod = vbTextCompare
End If
Contains = (InStr(1, string_source, find_text, compareMethod) <> 0)
End Function