Skip to main content
Code Review

Return to Question

Notice removed Draw attention by Community Bot
Bounty Ended with JimmyB's answer chosen by Community Bot
fix typo
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
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 isif 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
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 is 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
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
Correct examples with the Create syntax
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
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 New AsciiProgressBar
 Set progress.Init = 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
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 New AsciiProgressBar.Init 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
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 New AsciiProgressBar
 progress.Init 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
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 New AsciiProgressBar.Init 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
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
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
Added a create method and some improved formatting - I haven't got any answers or comments yet, so should be fine
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
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 is 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
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

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

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 is 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 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

Rubberduck advises against overwriting variables passed ByVal, why? Is it safe here?

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 is 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
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

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

Notice added Draw attention by Greedo
Bounty Started worth 50 reputation by Greedo
fix typo
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
Loading
Rearrange gifs and add tag
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
Loading
Tweeted twitter.com/StackCodeReview/status/1066934702009970688
Fix gifs
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
Loading
Source Link
Greedo
  • 2.6k
  • 2
  • 15
  • 36
Loading
lang-vb

AltStyle によって変換されたページ (->オリジナル) /