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
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
NB actual operation is much smoother, the gif is just low quality
