Rob,
Paste the appended code to a standard (suggest separate) code module. The
progress bar is created if it does not already exist and is destroyed
automatically upon reaching 100% (Terefore, it must be recreated for each run
of the macro). The vast majority of the code is used to create the progress
bar. It could be rewritten to toggle the visible status instead and thus the
code required to operate it would be drastically reduced. I don't like hidden
shapes. That's why I did it this way.
I didn't append the more complex version because I thought it inappropriate.
It is more complex to operate but also allows text messaging and changing the
band colour.
To repeat, when you first call the PB, if you don't specify Size, Left and
Top properties it will use defaults. Afterwards, you need only specify the
value property.
First call example: ProgressBar 5, 170, 100, 100
Subsequent call example: ProgressBar 50
Regards,
Greg
Code follows:-
'Developed by Greg Wilson
'Last Modified: August 2005
'Use of GetDeviceCaps/GetDC/ReleaseDC derived from Stephen Bullen post
'This post apparently no longer available
'Displays simple 3D progress bar constructed of grouped Excel drawing objects
Dim ProgBar As Shape
Dim R1 As Shape, R2 As Shape, R3 As Shape
Dim R4 As Shape, R5 As Shape
Const defSize As Single = 200
Const defLeft As Single = 50
Const defTop As Single = 50
Const defMainBackColor As Single = 12766158
Const defWindowBackColor As Single = vbWhite
Const defIndColor As Single = vbBlue
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" _
(ByVal dwMilliseconds As Long)
Sub ProgressBar(Val, Optional Size, Optional Left, Optional Top)
If IsMissing(Size) Then Size = defSize
If IsMissing(Left) Then Left = defLeft
If IsMissing(Top) Then Top = defTop
On Error GoTo Destroy
If Not ProgressBarExists Then
MakeProgressBar Val, Size, Left, Top
Else
With ProgBar
.GroupItems(3).Width = Val / 100 * .GroupItems(4).Width
End With
DoEvents
If Val = 100 Then GoTo Destroy
End If
Exit Sub
Destroy:
Sleep 200
ProgBar.Delete
Set ProgBar = Nothing
On Error GoTo 0
End Sub
Private Sub MakeProgressBar(Val, Size, Left, Top)
Dim L As Single, T As Single, W As Single
Dim H As Single, x As Single
With ActiveSheet.Shapes
Set R1 = .AddShape(1, Left, Top, Size, Size / 8)
R1.Fill.ForeColor.RGB = defMainBackColor
Call Make3d(R1, "Raised")
L = Left + 0.04 * Size: T = Top + 0.04 * Size
W = 0.92 * Size: H = 0.05 * Size
Set R2 = .AddShape(1, L, T, W, H)
R2.Line.Visible = False
R2.Fill.ForeColor.RGB = defWindowBackColor
W = 0
Set R3 = .AddShape(1, L, T, W, H)
R3.Line.Visible = False
R3.Fill.ForeColor.RGB = defIndColor
R3.Width = Val / 100 * Size
W = 0.92 * Size
Set R4 = .AddShape(1, L, T, W, H)
R4.Fill.Visible = False
Call Make3d(R4, "Sunken")
Set ProgBar = .Range(Array(R1.Name, R2.Name, R3.Name, R4.Name)).Group
ProgBar.Name = "GW_ProgressBar"
End With
DoEvents
End Sub
Private Sub Make3d(Shp As Shape, EffectType As String)
Dim i As Integer, LineGroup As Shape
Dim L As Single, T As Single, W As Single, H As Single
Dim L1 As Object, L2 As Object, L3 As Object, L4 As Object
L = Shp.Left: T = Shp.Top: W = Shp.Width: H = Shp.Height
Shp.Line.Visible = False
With ActiveSheet
.Unprotect
With .Shapes
Set L1 = .BuildFreeform(msoEditingCorner, 0, 10)
L1.AddNodes msoSegmentCurve, msoEditingCorner, 0, 0
L1.AddNodes msoSegmentCurve, msoEditingCorner, 10, 0
Set L1 = L1.ConvertToShape
Set L2 = L1.Duplicate
L1.Width = W - 2 * PPPX: L1.Height = H - 2 * PPPY
L1.Left = L + PPPX: L1.Top = T + PPPY
L2.Width = W - PPPX: L2.Height = H - PPPY
L2.Left = L: L2.Top = T
Set L3 = .BuildFreeform(msoEditingCorner, 0, 10)
L3.AddNodes msoSegmentCurve, msoEditingCorner, 10, 10
L3.AddNodes msoSegmentCurve, msoEditingCorner, 10, 0
Set L3 = L3.ConvertToShape
Set L4 = L3.Duplicate
L3.Width = W - 2 * PPPX: L3.Height = H - 2 * PPPY
L3.Left = L + PPPX: L3.Top = T + PPPY
L4.Width = W: L4.Height = H
L4.Left = L: L4.Top = T
End With
Select Case EffectType
Case "Raised"
L1.Line.ForeColor.RGB = RGB(240, 240, 240)
L2.Line.ForeColor.RGB = RGB(220, 220, 220)
L3.Line.ForeColor.RGB = RGB(150, 150, 150)
L4.Line.ForeColor.RGB = RGB(50, 50, 50)
Set R1 = .Shapes.Range(Array _
(Shp.Name, L1.Name, L2.Name, L3.Name, L4.Name)).Group
Case "Sunken"
L1.Line.ForeColor.RGB = RGB(50, 50, 50)
L2.Line.ForeColor.RGB = RGB(150, 150, 150)
L3.Line.ForeColor.RGB = RGB(210, 210, 210)
L4.Line.ForeColor.RGB = RGB(240, 240, 240)
Set R4 = .Shapes.Range(Array _
(Shp.Name, L1.Name, L2.Name, L3.Name, L4.Name)).Group
End Select
End With
End Sub
Private Function ProgressBarExists() As Boolean
On Error Resume Next
Set ProgBar = ActiveSheet.Shapes("GW_ProgressBar")
ProgressBarExists = (Err.Number = 0)
On Error GoTo 0
End Function
Private Function PPPX() As Double
'Derived from Stephen Bullen post
Dim hDC As Long
hDC = GetDC(0)
PPPX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function
Private Function PPPY() As Double
'Derived from Stephen Bullen post
Dim hDC As Long
hDC = GetDC(0)
PPPY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function
I will see if I can't get a text box in a user form to do