L
Lars Uffmann
Hey everyone!
Since this gave me a headache yesterday and today, I thought I'd put it
in a distributable format and share it.
Have fun
Lars
' Module: mProgressBar
' Version: 2008-07-25
' Author: Lars Uffmann, (e-mail address removed)
' Purpose: provide an easy to use progress bar for MS Excel
' License: BSD
' * Copyright (c) 2008, Lars Uffmann, Cologne, Germany
' * All rights reserved.
' *
' * Redistribution and use in source and binary forms, with or without
' * modification, are permitted provided that the following
conditions are met:
' * * Redistributions of source code must retain the above copyright
' * notice, this list of conditions and the following disclaimer.
' * * Redistributions in binary form must reproduce the above
copyright
' * notice, this list of conditions and the following
disclaimer in the
' * documentation and/or other materials provided with the
distribution.
' * * Neither the name of the <organization> nor the
' * names of its contributors may be used to endorse or promote
products
' * derived from this software without specific prior written
permission.
' *
' * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ''AS IS'' AND ANY
' * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED
' * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE
' * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY
' * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES
' * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES;
' * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND
' * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT
' * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS
' * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' Example Usage:
' initializeProgress
' showProgress "My Progress Indicator", "Please stand by while data is
being processed..."
' ' do something
' updateProgress 30#
' ' do something
' updateProgress 80#
' ' do something
' updateProgress 100# ' this only makes sense if you give the user some
time to
' ' admire the complete progress bar before closing
the form
' closeProgress
Option Explicit
Private existsFrmProgress As Boolean ' has the form already been created?
Private hRootFrmProgress As Object ' handle for object creation,
ShowModal property and later removal
Private hOuterFrmProgress As Object ' handle for "outer" form
properties & methods, e.g. size, position, show()
Private frmProgress As UserForm ' handle for UserForm properties access
Private Const pbAUTOSIZE As Long = -1 ' for better readability
' this is the default value for optional size and position parameters
Private Const pbAVG_CHAR_WIDTH As Long = 5 ' used to autosize the form
width
Private Const pbMARGIN_LEFT As Long = 15 ' left margin
Private Const pbMARGIN_RIGHT As Long = 15 ' right margin
Private Const pbMARGIN_TOP As Long = 10 ' top margin
Private Const pbMARGIN_BOTTOM As Long = 10 ' bottom margin: ignored if
the progress bar gets too small
Private Const pbSYSMENU_HEIGHT As Long = 21 ' actual height 20.75 but I
don't wanna bother with Doubles here
Private Const pbLABEL_HEIGHT As Long = 18 ' used to autosize the form
height
Private Const pbBEST_BAR_HEIGHT As Long = 20 ' used to autosize the form
height
Private Const pbMIN_BAR_HEIGHT As Long = 5 ' used to autosize the
progress bar
Private Const pbDEF_MIN_VALUE As Double = 0# ' default minimum for
progress bar value range
Private Const pbDEF_MAX_VALUE As Double = 100# ' default maximum for "
' Procedure: initializeProgress
' Purpose: reset the module-global variables
' Example Usage: initializeProgress
Public Sub initializeProgress()
Set hRootFrmProgress = Nothing
Set hOuterFrmProgress = Nothing
Set frmProgress = Nothing
existsFrmProgress = False
End Sub
' Procedure: showProgress
' Purpose: create a UserForm, add a text and a progress bar, size
everything and display it
' Example Usage: showProgress
Public Sub showProgress(Optional title As String = "Progress Bar", _
Optional message As String = "Please stand by while the
operation is being processed...", _
Optional wWidth As Long = pbAUTOSIZE, Optional wHeight As Long
= pbAUTOSIZE, _
Optional wLeft As Long = pbAUTOSIZE, Optional wTop As Long =
pbAUTOSIZE, _
Optional minValue As Double = pbDEF_MIN_VALUE, Optional
maxValue As Double = pbDEF_MAX_VALUE)
Dim curTop As Long
If (existsFrmProgress) Then
MsgBox "form already there!"
Exit Sub
End If
existsFrmProgress = True
' For this next operation to work, you need to have "Trust Access to
visual basic project" checked
' in the macro security (Tools -> Options -> Security -> Macro Security)
Set hRootFrmProgress =
Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_MSForm)
' do not display modal, otherwise code execution will be stopped
until window is closed by the user
hRootFrmProgress.Properties("ShowModal") = False
' use of Name property omitted because VBA bugs out here if a previously
used name is reused (same session)
' hRootFrmProgress.Properties("Name") = "UserForm_Progress"
Set hOuterFrmProgress = VBA.UserForms.Add(hRootFrmProgress.Name) '
get outer form handle
Set frmProgress = hOuterFrmProgress ' typecast to UserForm handle
' determine autosizes as required
If wWidth = pbAUTOSIZE Then wWidth = pbMARGIN_LEFT + Len(message) *
pbAVG_CHAR_WIDTH + pbMARGIN_RIGHT
If wHeight = pbAUTOSIZE Then wHeight = pbMARGIN_TOP +
pbSYSMENU_HEIGHT + pbLABEL_HEIGHT + pbBEST_BAR_HEIGHT + pbMARGIN_BOTTOM
' initialize form
With hOuterFrmProgress
.Caption = title
.width = wWidth
.height = wHeight
End With
' initalize vertical position for next control
curTop = pbMARGIN_TOP
' create & initialize label for message text
frmProgress.Controls.Add "Forms.Label.1", "lblMessage", True
With frmProgress("lblMessage")
.Caption = message
.left = pbMARGIN_LEFT
.top = curTop
.width = frmProgress.InsideWidth - pbMARGIN_LEFT - pbMARGIN_RIGHT
' re-initalize vertical position for next control
curTop = curTop + .height
End With
' create & initialize progress bar
frmProgress.Controls.Add "MSComctlLib.ProgCtrl.2", "prgProcessing",
True
With frmProgress("prgProcessing")
.left = pbMARGIN_LEFT
.top = curTop
.width = frmProgress.InsideWidth - pbMARGIN_LEFT - pbMARGIN_RIGHT
If (frmProgress.InsideHeight - curTop - pbMARGIN_BOTTOM) >
pbMIN_BAR_HEIGHT Then
.height = frmProgress.InsideHeight - curTop - pbMARGIN_BOTTOM
Else
.height = pbMIN_BAR_HEIGHT
End If
' work around the *extremely annoying* behaviour of the
progress bar value range
If minValue < .min Then .min = minValue
If maxValue > .max Then .max = maxValue
.Value = minValue
.min = minValue
.max = maxValue
' re-initalize vertical position for next control
curTop = curTop + .height
End With
' display form centered (.Show does this)
hOuterFrmProgress.Show
' re-position form if required
If (wLeft <> pbAUTOSIZE) Then hOuterFrmProgress.left = wLeft
If (wTop <> pbAUTOSIZE) Then hOuterFrmProgress.top = wTop
' force full (initial) painting of form
frmProgress.Repaint
End Sub
' Procedure: updateProgress
' Purpose: show some progress
' Example Usage: updateProgress 50#
Public Sub updateProgress(progress As Double)
If Not existsFrmProgress Then
Exit Sub
End If
' update progress bar value & force repaint of form
frmProgress("prgProcessing").Value = progress
frmProgress.Repaint
End Sub
' Procedure: closeProgress
' Purpose: close & delete the UserForm
' Example Usage: closeProgress
Public Sub closeProgress()
If Not existsFrmProgress Then
MsgBox "form not there, can't close!"
Exit Sub
End If
' close form
Unload hOuterFrmProgress
' delete form
Application.VBE.ActiveVBProject.VBComponents.Remove hRootFrmProgress
' reset global variables
initializeProgress
End Sub
Since this gave me a headache yesterday and today, I thought I'd put it
in a distributable format and share it.
Have fun
Lars
' Module: mProgressBar
' Version: 2008-07-25
' Author: Lars Uffmann, (e-mail address removed)
' Purpose: provide an easy to use progress bar for MS Excel
' License: BSD
' * Copyright (c) 2008, Lars Uffmann, Cologne, Germany
' * All rights reserved.
' *
' * Redistribution and use in source and binary forms, with or without
' * modification, are permitted provided that the following
conditions are met:
' * * Redistributions of source code must retain the above copyright
' * notice, this list of conditions and the following disclaimer.
' * * Redistributions in binary form must reproduce the above
copyright
' * notice, this list of conditions and the following
disclaimer in the
' * documentation and/or other materials provided with the
distribution.
' * * Neither the name of the <organization> nor the
' * names of its contributors may be used to endorse or promote
products
' * derived from this software without specific prior written
permission.
' *
' * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ''AS IS'' AND ANY
' * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED
' * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE
' * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY
' * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES
' * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES;
' * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND
' * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT
' * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS
' * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' Example Usage:
' initializeProgress
' showProgress "My Progress Indicator", "Please stand by while data is
being processed..."
' ' do something
' updateProgress 30#
' ' do something
' updateProgress 80#
' ' do something
' updateProgress 100# ' this only makes sense if you give the user some
time to
' ' admire the complete progress bar before closing
the form
' closeProgress
Option Explicit
Private existsFrmProgress As Boolean ' has the form already been created?
Private hRootFrmProgress As Object ' handle for object creation,
ShowModal property and later removal
Private hOuterFrmProgress As Object ' handle for "outer" form
properties & methods, e.g. size, position, show()
Private frmProgress As UserForm ' handle for UserForm properties access
Private Const pbAUTOSIZE As Long = -1 ' for better readability
' this is the default value for optional size and position parameters
Private Const pbAVG_CHAR_WIDTH As Long = 5 ' used to autosize the form
width
Private Const pbMARGIN_LEFT As Long = 15 ' left margin
Private Const pbMARGIN_RIGHT As Long = 15 ' right margin
Private Const pbMARGIN_TOP As Long = 10 ' top margin
Private Const pbMARGIN_BOTTOM As Long = 10 ' bottom margin: ignored if
the progress bar gets too small
Private Const pbSYSMENU_HEIGHT As Long = 21 ' actual height 20.75 but I
don't wanna bother with Doubles here
Private Const pbLABEL_HEIGHT As Long = 18 ' used to autosize the form
height
Private Const pbBEST_BAR_HEIGHT As Long = 20 ' used to autosize the form
height
Private Const pbMIN_BAR_HEIGHT As Long = 5 ' used to autosize the
progress bar
Private Const pbDEF_MIN_VALUE As Double = 0# ' default minimum for
progress bar value range
Private Const pbDEF_MAX_VALUE As Double = 100# ' default maximum for "
' Procedure: initializeProgress
' Purpose: reset the module-global variables
' Example Usage: initializeProgress
Public Sub initializeProgress()
Set hRootFrmProgress = Nothing
Set hOuterFrmProgress = Nothing
Set frmProgress = Nothing
existsFrmProgress = False
End Sub
' Procedure: showProgress
' Purpose: create a UserForm, add a text and a progress bar, size
everything and display it
' Example Usage: showProgress
Public Sub showProgress(Optional title As String = "Progress Bar", _
Optional message As String = "Please stand by while the
operation is being processed...", _
Optional wWidth As Long = pbAUTOSIZE, Optional wHeight As Long
= pbAUTOSIZE, _
Optional wLeft As Long = pbAUTOSIZE, Optional wTop As Long =
pbAUTOSIZE, _
Optional minValue As Double = pbDEF_MIN_VALUE, Optional
maxValue As Double = pbDEF_MAX_VALUE)
Dim curTop As Long
If (existsFrmProgress) Then
MsgBox "form already there!"
Exit Sub
End If
existsFrmProgress = True
' For this next operation to work, you need to have "Trust Access to
visual basic project" checked
' in the macro security (Tools -> Options -> Security -> Macro Security)
Set hRootFrmProgress =
Application.VBE.ActiveVBProject.VBComponents.Add(vbext_ct_MSForm)
' do not display modal, otherwise code execution will be stopped
until window is closed by the user
hRootFrmProgress.Properties("ShowModal") = False
' use of Name property omitted because VBA bugs out here if a previously
used name is reused (same session)
' hRootFrmProgress.Properties("Name") = "UserForm_Progress"
Set hOuterFrmProgress = VBA.UserForms.Add(hRootFrmProgress.Name) '
get outer form handle
Set frmProgress = hOuterFrmProgress ' typecast to UserForm handle
' determine autosizes as required
If wWidth = pbAUTOSIZE Then wWidth = pbMARGIN_LEFT + Len(message) *
pbAVG_CHAR_WIDTH + pbMARGIN_RIGHT
If wHeight = pbAUTOSIZE Then wHeight = pbMARGIN_TOP +
pbSYSMENU_HEIGHT + pbLABEL_HEIGHT + pbBEST_BAR_HEIGHT + pbMARGIN_BOTTOM
' initialize form
With hOuterFrmProgress
.Caption = title
.width = wWidth
.height = wHeight
End With
' initalize vertical position for next control
curTop = pbMARGIN_TOP
' create & initialize label for message text
frmProgress.Controls.Add "Forms.Label.1", "lblMessage", True
With frmProgress("lblMessage")
.Caption = message
.left = pbMARGIN_LEFT
.top = curTop
.width = frmProgress.InsideWidth - pbMARGIN_LEFT - pbMARGIN_RIGHT
' re-initalize vertical position for next control
curTop = curTop + .height
End With
' create & initialize progress bar
frmProgress.Controls.Add "MSComctlLib.ProgCtrl.2", "prgProcessing",
True
With frmProgress("prgProcessing")
.left = pbMARGIN_LEFT
.top = curTop
.width = frmProgress.InsideWidth - pbMARGIN_LEFT - pbMARGIN_RIGHT
If (frmProgress.InsideHeight - curTop - pbMARGIN_BOTTOM) >
pbMIN_BAR_HEIGHT Then
.height = frmProgress.InsideHeight - curTop - pbMARGIN_BOTTOM
Else
.height = pbMIN_BAR_HEIGHT
End If
' work around the *extremely annoying* behaviour of the
progress bar value range
If minValue < .min Then .min = minValue
If maxValue > .max Then .max = maxValue
.Value = minValue
.min = minValue
.max = maxValue
' re-initalize vertical position for next control
curTop = curTop + .height
End With
' display form centered (.Show does this)
hOuterFrmProgress.Show
' re-position form if required
If (wLeft <> pbAUTOSIZE) Then hOuterFrmProgress.left = wLeft
If (wTop <> pbAUTOSIZE) Then hOuterFrmProgress.top = wTop
' force full (initial) painting of form
frmProgress.Repaint
End Sub
' Procedure: updateProgress
' Purpose: show some progress
' Example Usage: updateProgress 50#
Public Sub updateProgress(progress As Double)
If Not existsFrmProgress Then
Exit Sub
End If
' update progress bar value & force repaint of form
frmProgress("prgProcessing").Value = progress
frmProgress.Repaint
End Sub
' Procedure: closeProgress
' Purpose: close & delete the UserForm
' Example Usage: closeProgress
Public Sub closeProgress()
If Not existsFrmProgress Then
MsgBox "form not there, can't close!"
Exit Sub
End If
' close form
Unload hOuterFrmProgress
' delete form
Application.VBE.ActiveVBProject.VBComponents.Remove hRootFrmProgress
' reset global variables
initializeProgress
End Sub