Progress Bar (1 Viewer)

isladogs

CID VIP
Local time
Today, 16:47
Joined
Jan 14, 2017
Messages
16,422
Attached is an updated version of my progress bar app.

The example app contains 4 forms with different variations of the progress bar:
1. using a solid bar with progress based on a series of events (update queries).

ProgressBar1.png


2. using a solid bar with progress done using a timer event.

ProgressBar2.png


3. using an image - in this case using colours from a flag. See Fig 3

ProgressBar3.png


4. using an image - in this case using a gradient fill. See Fig 4

ProgressBar4.png


The code is all in module modProgress:

Rich (BB code):
Option Compare Database
Option Explicit

Dim intMaxLength As Integer
Dim sngIncrement As Single

Global N As Long, iCount As Long
Global frm As Access.Form

'##############################
'module to manage progress bars for multiple forms
'##############################

Public Sub SetupProgressBar(frm As Form)

On Error GoTo ErrHandler

N = 0 'reset step count
If iCount = 0 Then iCount = 50 'default value for number of steps if not set on host form

intMaxLength = frm.boxProgressBottom.Width
sngIncrement = frm.boxProgressBottom.Width / iCount

frm.boxProgressTop.Width = 0
frm.lblProgressCaption.Caption = "0%"
frm.boxProgressBottom.Visible = True
frm.boxProgressTop.Visible = True
frm.lblProgressCaption.Visible = True
frm.lblProgressCaption.ForeColor = vbBlack
frm.Repaint
DoEvents

ExitHandler:
    Exit Sub

ErrHandler:   
  'err 2475 = the form listed isn't active; err 2467 = object closed
    If Err = 2475 Or err=2467 Then
        Exit Sub
    Else
        MsgBox "Error " & Err.Number & " in SetupProgressBar procedure : " & Err.Description
        Resume ExitHandler
    End If


End Sub

'================================

Public Sub UpdateProgressBar(frm As Form)

'############################################
' fore color changed at 55% 
'############################################

On Error GoTo ErrHandler

'update progress bar
N = N + 1

If frm.boxProgressTop.Width < intMaxLength Then
    DoEvents   'needed to let computer continue with other tasks
    frm.boxProgressTop.Width = (frm.boxProgressTop.Width + sngIncrement)
    frm.lblProgressCaption.Caption = Int(100 * (frm.boxProgressTop.Width / intMaxLength)) & "%"

    If frm.boxProgressTop.Width / intMaxLength > 0.55 Then frm.lblProgressCaption.ForeColor = vbYellow
End If

frm.Repaint
DoEvents

ExitHandler:
    Exit Sub

ErrHandler:
     'err 2475 = the form listed isn't active; err 2467 = object closed
    If Err = 2475 Or err=2467 Then
        Exit Sub
    Else
        MsgBox "Error " & Err.Number & " in UpdateProgressBar procedure : " & Err.Description
        Resume ExitHandler
    End If

End Sub

'================================

Public Sub HideProgressBar(frm As Form)

On Error GoTo ErrHandler

'Hide progress bar
frm.boxProgressBottom.Visible = False
frm.boxProgressTop.Visible = False
frm.lblProgressCaption.Visible = False

iCount = 0
N = 0

ExitHandler:
    Exit Sub

ErrHandler:
   'err 2475 = the form listed isn't active; err 2467 = object closed
    If Err = 2475 Or err=2467 Then
        Exit Sub
    Else
        MsgBox "Error " & Err.Number & " in HideProgressBar procedure : " & Err.Description
        Resume ExitHandler
    End If
      
End Sub

Typical usage:

Rich (BB code):
Private Sub cmdStart_Click()

If Me.cmdStart.Caption = "Start" Then
      Me.cmdStart.Caption = "Stop"

     'enter number of steps to be run e.g. 5

      iCount = 5
      SetupProgressBar Me

      'step 1 - run some code here e.g. update query & update progress bar
      CurrentDb.Execute "UPDATE . . . ", dbFailOnError
      UpdateProgressBar Me
      DoEvents     'pause to allow screen to update

      'step 2 - run some more code here e.g. append query & update progress bar
      CurrentDb.Execute "INSERT . . . ", dbFailOnError
      UpdateProgressBar Me
      DoEvents

      'step 3 - run some more code here e.g. update query & update progress bar
      CurrentDb.Execute "UPDATE . . . ", dbFailOnError
      UpdateProgressBar Me
      DoEvents

      'step 4 - run some more code here e.g. append query & update progress bar
      CurrentDb.Execute "INSERT . . . ", dbFailOnError
      UpdateProgressBar Me
      DoEvents

      'step 5 - run some more code here e.g. delete query & update progress bar
      CurrentDb.Execute "DELETE . . . ", dbFailOnError
      UpdateProgressBar Me
      DoEvents

      'pause briefly to show completed
      Me.LblHelpText.Caption = "Updates completed . . . "
      DoEvents

      'reset form
      Me.cmdStart.Caption = "Start"

      'hide progress bar and help text
      HideProgressBar Me
      Me.LblHelpText.Visible = False

Else
      'reset form if process stopped by user
      Me.cmdStart.Caption = "Start"
      HideProgressBar Me
      Me.LblHelpText.Visible = False

End If

End Sub


For more details, see my website article:
 

Attachments

  • ExampleProgressBars_v2.zip
    150 KB · Views: 96
Last edited:

Miki13

New member
Local time
Today, 17:47
Joined
May 25, 2022
Messages
8
Thanks, very useful! :love:
 

Users who are viewing this thread

Top Bottom