I've been wanting to experiment with a bit of error handling and robustness to make my code more user friendly. I was inspired bythis 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 ExplicitPrivate Type tProgressBar    percentComplete As Double    size As Long    base As String    bar As String    character As String    whitespace As String    mask As StringEnd TypePrivate Enum progressError    percentOutOfBoundsError = vbObjectError + 513 'to get into custom error raising territory    barSizeOutOfRangeError    singleCharacterRequiredError    baseIsNotAStringError    maskMissingPositionalArgumentErrorEnd EnumPrivate Const DEFAULT_CHAR As String = "|"Private Const DEFAULT_SIZE As Long = 10Private Const DEFAULT_BASE As String = vbNullStringPrivate Const DEFAULT_WHITESPACE As String = " "Private Const DEFAULT_MASK As String = "{0}{1}{2}%"Private this As tProgressBarPublic 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 = reprEnd FunctionPublic Property Get repr() As String    repr = printf(this.mask, this.base, this.bar, Round(this.percentComplete * 100, 0))End PropertyPrivate 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 0Debug.Print printf("Warning: Unexpected error '{0}' with description '{1}'", errNum, errDescription)    End Select    Err.Raise errNumEnd SubPublic 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 = formatMaskEnd SubPrivate 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    NextEnd FunctionPrivate Sub Class_Initialize()    ResetDefaults    Update this.percentCompleteEnd SubPublic Sub ResetDefaults()    this.character = DEFAULT_CHAR    this.base = DEFAULT_BASE    this.whitespace = DEFAULT_WHITESPACE    this.size = DEFAULT_SIZE    this.mask = DEFAULT_MASKEnd SubPublic 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 = resultEnd 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 = maskEnd Function

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

VERSION 1.0 CLASSBEGIN  MultiUse = -1  'TrueENDAttribute VB_Name = "AsciiProgressBar"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute 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 passedByVal - e.g in theInit method - why? Is it safe here?

Examples

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

Using a worksheet button (ActiveX)

Best to use a monospaced font likeConsolas

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Private stillHeld As BooleanPrivate 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 SubPrivate Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)    stillHeld = FalseEnd Sub

UsingApplication.StatusBar

Option ExplicitPrivate 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 = FalseEnd Sub

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

1 Answer1

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.