20
\$\begingroup\$

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

ProgressView showing 41.1% completed

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
\$\endgroup\$
  • 4
    \$\begingroup\$ If anyone is interested, I've uploaded this code to my VBTools repository on GitHub. \$\endgroup\$ – Mathieu Guindon Apr 27 '15 at 15:26
18
\$\begingroup\$

There are a number of (minor) issues here.

Re-raising errors

This is rather ugly:

Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext

Per MSDN, Err.Raise can "rethrow" an error much cleaner than that:

All of the Raise arguments except Number are optional. If you omit optional arguments, and the property settings of the Err object contain values that have not been cleared, those values serve as the values for your error.

This means the above can be shortened to, Err.Raise Err.Number.


Magic Constants

Other than the hard-coded error numbers mentioned in @Snowbody's answer...

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        Cancel = True
        RaiseEvent Cancelled
    End If
End Sub

...0 is a magic value in CloseMode = 0; the VBA standard library defines the vbQueryClose enum for that purpose - replacing value 0 with vbQueryClose.vbFormControlMenu makes it much clearer that the condition is evaluating whether the CloseMode is related to the user clicking the red "X" in the form's control box.


Cancellation

This is totally unacceptable UX - this error will bring up a VBA debugger window prompting the user to End execution or Debug the code... which makes it a feature that feels like a bug!

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

Raising an untrappable error doesn't cancel the task in progress, it nukes it.

nuke

You have already cancelled the form's closing; all you need to do is to forbid the cancellation of the task in progress... unless the client code has an explicit way of handling cancellation - and you can let the client code know the user intends to cancel the task, by raising an event.

I would add a canCancel member to this, which would only be True when the "DoWork" code is located in a class module (i.e. when the ProgressIndicator instance can be a Private WithEvents field) - then you can leave it up to the client code to decide whether they want to nuke the long-running process, or handle it cleanly.

So you add a BeforeCancel event to the ProgressIndicator:

Public Event BeforeCancel(ByRef throw As Boolean)

And you raise it before the nuke goes off, to allow the client code to set throw to False and deal with cleanly cancelling the task:

Private Sub view_Cancelled()

    If Not this.canCancel Then Exit Sub

    Dim throw As Boolean
    throw = True
    RaiseEvent BeforeCancel(throw)

    'this error isn't trappable, but not raising it wouldn't cancel anything:
    If throw Then OnCancelledError

End Sub

Then the client code can have a Boolean flag to capture the cancelling state of the progress indicator:

Private WithEvents indicator As ProgressIndicator
Private isCancelling As Boolean

And deal with the BeforeCancel event like this:

Private Sub indicator_BeforeCancel(throw As Boolean)
    isCancelling = True
    throw = False
End Sub

Private Sub OnProgressCancelled()
    Err.Raise ProgressIndicatorError.Error_OperationCancelled, TypeName(Me), "Operation was cancelled."
End Sub

And now the "DoWork" code can periodically evaluate the isCancelling flag, and act accordingly:

For Each record In data

    If isCancelling Then OnProgressCancelled

    ...

...resulting in a clean cancellation:

operation was cancelled. 0/6 transactions committed.

\$\endgroup\$
  • 2
    \$\begingroup\$ lol +1 just for nuke graphic^^ \$\endgroup\$ – findwindow Jun 1 '16 at 16:06
7
+25
\$\begingroup\$
Update percentValue, Format(percentValue, "0.0% Completed")

Maybe make the format string settable, in case the code is used in a different language, or one which uses a different character as the integer-fraction separator.

    percentValue = percentValue / 100

Isn't * .01 faster?

What's the magic number 438? It's there twice, can you make it a Const at least?

Seriously, this is very good code, that's the reason you're not getting much attention, there's not much to suggest!

\$\endgroup\$
  • 2
    \$\begingroup\$ Runtime error 438 is Object does not support property or method, raised if we try calling DoSomething on an object that doesn't have such a member. \$\endgroup\$ – Mathieu Guindon Apr 29 '15 at 4:22
  • 4
    \$\begingroup\$ You don't have a module that defines all of the built in runtime errors yet? \$\endgroup\$ – RubberDuck Apr 29 '15 at 4:33
  • 2
    \$\begingroup\$ @RubberDuck I... don't have that... yet. \$\endgroup\$ – Mathieu Guindon Apr 29 '15 at 4:34
  • \$\begingroup\$ @RubberDuck : That's interesting indeed, can you share it with us somehow, pretty please? o:) \$\endgroup\$ – R3uK Apr 30 '15 at 15:54
  • \$\begingroup\$ Yeah. I don't see why not @R3uK. I'll add it to the VBEX repo sometime next week. So, you can watch that repo for it. I thought it was already in there, but I'll need to add it I guess. github.com/ckuhn203/VBEX \$\endgroup\$ – RubberDuck Apr 30 '15 at 15:57
3
\$\begingroup\$

Create an IProgress interface, and have your class implement the interface. Then the interface can be reimplemented by Access forms that do the same thing, or by classes that encapsulate the application's own status bar progress indicator, or any other class that wants to show progress using DrawRectangle, or the ribbon, or Excel cells, or Excel charts, or an InternetExplorer window, or ASCII art or whatever.

Then any routine that currently accepts a ProgressIndicator would change to accept any class that implements an IProgress interface.

The interface only exposes the properties and methods that make it usable, and the interface abstracts away any dependency on Excel.

Any class that consumes an IProgress can then run 'silently' without any problems, where IProgess won't actually implement progress.

\$\endgroup\$
  • \$\begingroup\$ Great advice, but you should know that you can use UserForms in Access too! =) \$\endgroup\$ – RubberDuck Jan 13 '16 at 0:09
  • \$\begingroup\$ Indeed you can, but the VBIDE under Access makes it hard to add them. You can add them from an import, or by adding a button to the Toolbars... Just don't try dragging a VBForm from an Excel project to an Access project, or you'll get unpredictable results. \$\endgroup\$ – ThunderFrame Jan 13 '16 at 1:11
  • \$\begingroup\$ There are merits to using VB forms in Access, particularly for a Progress Bar, but sometimes you'll want the data-binding and/or sub-forms that Access forms offer. \$\endgroup\$ – ThunderFrame Jan 13 '16 at 1:12
  • \$\begingroup\$ No doubt! Just pointing it out. \$\endgroup\$ – RubberDuck Jan 13 '16 at 1:18

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.