Just paste this code into a Class Module and name the class module cGauge.
'----------------------------------------------------------------------
'
' Class Name: cGauge
' Written By: C&D Programming Corp.
' Copyright: Copyright 1997 by C&D Programming Corp.
' No reproduction or redistribution of this source
' code unless used in a compiled applcation. If you
' are interested in reprinted this source, please
' email us at info@codeoftheweek.com
' Create Date: 9/29/97
'
' Purpose: Implement a simple, quick gauge control without
' requiring an extra control to ship with your
' application.
'
' Notes: To use this, drop a picture control on the form
' where you want to have a gauge and size
' it to be the size you want. This class does
' not resize and controls.
'
' Sample Call: Dim G as New cGauge
'
' G.QuickStart pictGauge, 0, 100
' For x = 0 to 100
' ... Do something ...
' G.Current = x
' Next
'
' Modification History
'
' Date Description
' -------- ---------------------------------------------------
' 10/9/97 Fixed bug when you use the gauge several times in a
' row. It did not repaint the gauge correctly after
' the first use. See Refresh method for details.
'
' Added a PercentComplete subroutine
'----------------------------------------------------------------------
Option Explicit
Private mctlGauge As Control ' control to draw the gauge in
Private mlMin As Long ' min value of the gauge control
Private mlMax As Long ' max value of the gauge control
Private mlCurrent As Long ' current value of the gauge control
Private mlBarColor As Long ' color of the gauge bar, default is vbBlue
Private mlUpdateInterval As Long ' how often the bar actually gets drawn
' the bigger the interval the less the control
' actually gets updated. But, the bigger the
' interval, the less overhead the gauge
' imposes on the process you are running
' Drawing on a control is a very time
' consuming process as far as CPU cycles
' go.
Public Property Get GaugeControl() As Control
Set GaugeControl = mctlGauge
End Property
Public Property Set GaugeControl(ctlGauge As Control)
Set mctlGauge = ctlGauge
ctlGauge.AutoRedraw = True
BarColor = vbBlue
End Property
Public Property Get Min() As Long
Min = mlMin
End Property
Public Property Let Min(lMin As Long)
mlMin = lMin
End Property
'
' It is assumed the the Min value is set before the Max
' value.
'
Public Property Get Max() As Long
Max = mlMax
End Property
'
' It is assumed the the Min value is set before the Max
' value.
'
Public Property Let Max(lMax As Long)
mlMax = lMax
UpdateInterval = (lMax - Min) / 100
End Property
Public Property Get Current() As Long
Current = mlCurrent
End Property
Public Property Let Current(lCurrent As Long)
mlCurrent = lCurrent
Refresh
End Property
Public Property Get BarColor() As Long
BarColor = mlBarColor
End Property
Public Property Let BarColor(lBarColor As Long)
mlBarColor = lBarColor
End Property
Public Property Get UpdateInterval() As Long
UpdateInterval = mlUpdateInterval
End Property
Public Property Let UpdateInterval(lUpdateInterval As Long)
If lUpdateInterval = 0 Then
mlUpdateInterval = 1
Else
mlUpdateInterval = lUpdateInterval
End If
End Property
Public Function PercentComplete() As Single
PercentComplete = (Current / (Max - Min)) * 100
End Function
Public Sub Refresh()
If Current Mod UpdateInterval = 0 Then
Dim lMiddle As Long
lMiddle = (Current / (Max - Min)) * GaugeControl.Width
GaugeControl.Line (0, 0)-(lMiddle, GaugeControl.Height), BarColor, BF
GaugeControl.Line (lMiddle, 0)-(GaugeControl.Width, GaugeControl.Height), GaugeControl.BackColor, BF
GaugeControl.Refresh ' Force control to update
End If
End Sub
Public Sub QuickStart(ctl As Control, lMin As Long, lMax As Long)
Set GaugeControl = ctl
Min = lMin
Max = lMax
End Sub