9
\$\begingroup\$

I've been wanting to experiment with a bit of error handling and robustness to make my code more user friendly. I was inspired by this answer on UX to try and add a progress bar to a button - but was unable to find any simple text based progress bars out there, so I decided to write my own in that style. It boils down to a single class (which references a helper method in an addin: printf):

Class: AsciiProgressBar

Option Explicit

Private Type tProgressBar
    percentComplete As Double
    size As Long
    base As String
    bar As String
    character As String
    whitespace As String
    mask As String
End Type

Private Enum progressError
    percentOutOfBoundsError = vbObjectError + 513 'to get into custom error raising territory
    barSizeOutOfRangeError
    singleCharacterRequiredError
    baseIsNotAStringError
    maskMissingPositionalArgumentError
End Enum

Private Const DEFAULT_CHAR As String = "|"
Private Const DEFAULT_SIZE As Long = 10
Private Const DEFAULT_BASE As String = vbNullString
Private Const DEFAULT_WHITESPACE As String = " "
Private Const DEFAULT_MASK As String = "{0}{1}{2}%"

Private this As tProgressBar

Public Function Update(ByVal fractionComplete As Double) As String

    'check if valid input (0-100%)
    If fractionComplete < 0# Or fractionComplete > 1# Then raiseError percentOutOfBoundsError

    'set number of characters in progress bar
    this.percentComplete = fractionComplete
    Dim numberOfChars As Long
    numberOfChars = Round(this.size * this.percentComplete, 0)
    this.bar = String(numberOfChars, this.character) & String(this.size - numberOfChars, this.whitespace)

    Update = repr
End Function

Public Property Get repr() As String
    repr = printf(this.mask, this.base, this.bar, Round(this.percentComplete * 100, 0))
End Property

Private Sub raiseError(ByVal errNum As progressError, ParamArray args() As Variant)
    Select Case errNum
    Case percentOutOfBoundsError
        Err.Description = "Percent must lie between 0.0 and 1.0"
    Case barSizeOutOfRangeError
        Err.Description = printf("Bar size must be at least {0} characters", args(0))
    Case singleCharacterRequiredError
        Err.Description = printf("Only a single character should be used as {0}, not '{1}'", args(0), args(1))
    Case baseIsNotAStringError
        Err.Description = printf("Base must be of type string or left blank, not '{0}'", TypeName(args(0)))
    Case maskMissingPositionalArgumentError
        Err.Description = printf("formatMask must contain all three positional tokens ({0,1,2}){0}'{1}' does not", _
                                 vbCrLf, args(0))
    Case Else                                    'some errNum we don't know what to do with
        On Error Resume Next                     'fake raise to grab description text
        Err.Raise errNum
        Dim errDescription As String
        errDescription = Err.Description
        On Error GoTo 0
Debug.Print printf("Warning: Unexpected error '{0}' with description '{1}'", errNum, errDescription)
    End Select
    Err.Raise errNum
End Sub

Public Sub Init(Optional ByVal size As Long = 0, Optional ByVal base As Variant, _
                Optional ByVal character As String = vbNullString, Optional ByVal whitespace As String = vbNullString, _
                Optional ByVal formatMask As String = vbNullString)
    'Method to set appearence and other properties of the progress bar

    'check if inputs were missing - if so leave as they were
    'Base can be any string so can't be checked in this way, needs special handling
    size = IIf(size = 0, this.size, size)
    character = IIf(character = vbNullString, this.character, character)
    whitespace = IIf(whitespace = vbNullString, this.whitespace, whitespace)
    formatMask = IIf(formatMask = vbNullString, this.mask, formatMask)

    'check for valid inputs
    Const minBarSize As Long = 2
    If size < minBarSize Then
        raiseError barSizeOutOfRangeError, minBarSize
    ElseIf Len(character) <> 1 Then
        raiseError singleCharacterRequiredError, "'character'", character
    ElseIf Len(whitespace) <> 1 Then
        raiseError singleCharacterRequiredError, "'whitespace'", whitespace
    ElseIf MaskIsInvalid(formatMask) Then
        raiseError maskMissingPositionalArgumentError, formatMask
    ElseIf Not IsMissing(base) Then
        'base is variant so requires type checking
        On Error Resume Next
        this.base = base                         'may be type error if base can't be converted; e.g an object was passed
        Dim errNum As Long
        errNum = Err.Number
        On Error GoTo 0
        If errNum <> 0 Then
            raiseError baseIsNotAStringError, base
        End If
    End If

    'If we've got here then inputs are valid, so we can commit them
    this.size = size
    this.whitespace = whitespace
    this.character = character
    this.mask = formatMask

End Sub

Private Function MaskIsInvalid(ByVal mask As String) As Boolean
    'check whether any of the positional tokens don't appear in the mask
    Const matchPattern As String = "{0} {1} {2}"
    Dim tokens() As String
    tokens = Split(matchPattern)
    MaskIsInvalid = False
    Dim token As Variant
    For Each token In tokens
        MaskIsInvalid = Not CBool(InStr(mask, token))
        If MaskIsInvalid Then Exit Function
    Next
End Function

Private Sub Class_Initialize()
    ResetDefaults
    Update this.percentComplete
End Sub

Public Sub ResetDefaults()
    this.character = DEFAULT_CHAR
    this.base = DEFAULT_BASE
    this.whitespace = DEFAULT_WHITESPACE
    this.size = DEFAULT_SIZE
    this.mask = DEFAULT_MASK
End Sub

Public Function Create(Optional ByVal size As Long = 0, Optional ByVal base As Variant, _
                       Optional ByVal character As String = vbNullString, Optional ByVal whitespace As String = vbNullString, _
                       Optional ByVal formatMask As String = vbNullString) As AsciiProgressBar

    Dim result As New AsciiProgressBar
    result.Init size, base, character, whitespace, formatMask
    Set Create = result

End Function

Which references my addin

Public Function printf(ByVal mask As String, ParamArray tokens()) As String
'Format string with by substituting into mask - stackoverflow.com/a/17233834/6609896
    Dim i As Long
    For i = 0 To UBound(tokens)
        mask = Replace$(mask, "{" & i & "}", tokens(i))
    Next
    printf = mask
End Function

The class has a Create method as it is intended to be used in an addin (and pre-declared), i.e. the header looks like this:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "AsciiProgressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True

Feedback

I'd particularly like feedback on:

  • Robustness of code (to user input)
  • Ease of use
  • Error raising
  • Use of Init vs individual get/letters
  • Code writing and formatting style
  • Everything else :)

Rubberduck advises against overwriting variables passed ByVal - e.g in the Init method - why? Is it safe here?

Examples

The class can be used to supply content to userform text boxes, button captions, the Application.StatusBar, basically anywhere that displays strings; here are a couple of examples:

Using a worksheet button (ActiveX)

Best to use a monospaced font like Consolas

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private stillHeld As Boolean

Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'start loading progress bar

    Const numberOfSteps As Long = 50
    Dim progress As AsciiProgressBar
    Set progress = AsciiProgressBar.Create(size:=20, base:="Loading: ")
    stillHeld = True
    Dim i As Long
    For i = 1 To numberOfSteps
        CommandButton1.Caption = progress.Update(i / numberOfSteps)
        If Not stillHeld Then Exit For
        DoEvents
        Sleep 20
    Next i
    If i > numberOfSteps Then
        CommandButton1.Caption = "Held on long enough"
        DoEvents
        Sleep 1000
    Else
        CommandButton1.Caption = "Let go too early"
        DoEvents
        Sleep 1000
    End If
    CommandButton1.Caption = "Hold down"
End Sub

Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    stillHeld = False
End Sub

Command button

Using Application.StatusBar

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub StatusBarProgress()
    Const runningTime As Single = 5000           'in milliseconds
    Const numberOfSteps As Long = 100
    With AsciiProgressBar.Create(base:="Loading: ", formatMask:="{0}{2}%{1}|")
        Dim i As Long
        For i = 1 To numberOfSteps
            .Update i / numberOfSteps
            Application.StatusBar = .repr
            'Or equivalently:
            'Application.StatusBar = .Update(i / numberOfSteps)
            Sleep runningTime / numberOfSteps
            DoEvents
        Next i
    End With
    Application.StatusBar = False
End Sub

StatusBar

NB actual operation is much smoother, the gif is just low quality

\$\endgroup\$
3
+25
\$\begingroup\$

Rubberduck advises against overwriting variables passed ByVal - e.g in the Init method - why?

It's

  • a) coding style; keeping the original value in the parameter is supposed to be cleaner code because you can spot all the places where the exact passed in value is used and know where it is not used (but instead a modified/derived/sanitized version of it) and
  • b) assigning to a by-value parameter may be an error because the programmer intended the value to be seen by the caller, mistakenly thinking it was a ByRef. Your code is "safe" in this respect because you clearly do not assume the parameter is ByRef.

For best maintainability you should introduce new local variables for your input parameters' sanitized values, and make sure you only use those variables in the function and not accidentally use the original parameter at one place or another.

For my taste, a few more comments would be helpful. Those which are there are ok, though very brief. A rule of thumb: If it's not really obvious, why something is done in a program, explain the reason in a comment. Good example of a comment: 'fake raise to grab description text explains why we do a raise here.

In MaskIsInvalid, you don't need to use a pattern and Split to create the array of tokens. Just use tokens = Array("{0}","{1}","{2}").

\$\endgroup\$

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.