Home

Comments

If you find the Progress Bar that ships with Visual Basic a bit bland then this might take your fancy. You can set a Fore Picture and/or Back Picture. You can set whether they're Tiled, Stretched or AutoSized. The control is double-buffered, giving a smooth refresh.

There's also a Percent Property that I find very useful.

Reference

Progress Consts

Name	Type	Value	Description

DEFAULT_FORE_COLOR	Long	5242880	RGB(0, 0, 80)
DEFAULT_BACK_COLOR	Long	&H8000000F	Button Face
DEFAULT_FORE_STYLE	Long	1	psStretched
DEFAULT_BACK_STYLE	Long	2	psTiled

Progress Enums

ePictureStyle

Name	Value	Description

psAutoSized	0	The Control will resize to display the Picture in is origional dimensions.
psStretched	1	The Picture will be stretched.
psTiled	2	The Picture will be tiled both horozontally and vertically.

Progress Properties

Value [= NewValue]

Read-Write. The current value of the progress. If NewValue is greater than Max then Max is set to NewValue. Likewise, if NewValue is less than Min then Min is set to NewValue.

Return Type is a Long

Name	Type	Description

NewValue	Long

Min [= NewMin]

Read-Write. The Minimum value of the progress. If NewMin is greater than Max the Max is set to NewMin.

Return Type is a Long

Name	Type	Description

NewMin	Long

Max [= NewMax]

Read-Write. The Maximum value of the progress. If NewMax is less than Min then Min is set to NewMax.

Return Type is a Long

Name	Type	Description

NewMax	Long

Percent [= NewPercent]

Read-Write. The percent of the progress. If NewPercent is set below 0 then NewPercent is set to 0. If NewPercent is set above 100 then NewPercent is set to 100.

Return Type is a Long

Name	Type	Description

NewPercent	Long

ForeColor [= NewForeColor]

Read-Write. The fore color of the progress. If ForePicture is set then the ForeColor setting is ignored.

Return Type is a OLE_COLOR

Name	Type	Description

NewForeColor	OLE_COLOR

BackColor [= NewBackColor]

Read-Write. The back color of the progress. If BackPicture is set then the BackColor setting is ignored.

Return Type is a OLE_COLOR

Name	Type	Description

NewBackColor	OLE_COLOR

BackPicture [= NewPicture]

Read-Write. The back picture of the progress. The BackPicture is rendered using the BackStyle setting.

Return Type is a StdPicture

Name	Type	Description

NewPicture	StdPicture

ForePicture [= NewPicture]

Read-Write. The fore picture of the progress. The ForePicture is rendered using the ForeStyle setting.

Return Type is a StdPicture

Name	Type	Description

NewPicture	StdPicture

BackStyle [= NewStyle]

Read-Write. The BackStyle property detirmines how the BackPicture (if it is set) will be rendered. The default BackStyle is psTiled. If BackStyle is set to psAutoSized and ForeStyle is already set to psAutoSized then the ForeStyle will be set to is default Value.

Return Type is a ePictureStyle

Name	Type	Description

NewStyle	ePictureStyle

ForeStyle [= NewStyle]

Read-Write. The ForeStyle property detirmines how the ForePicture (if it is set) will be rendered. The default ForeStyle is psStretched. If ForeStyle is set to psAutoSized and BackStyle is already set to psAutoSized then the BackStyle will be set to is default Value.

Return Type is a ePictureStyle

Name	Type	Description

NewStyle	ePictureStyle

Progress Methods

About

Displays the About Box.

Usage

Add Progress.ctl to your project and ensure that Progress.ctx is in the same folder as Progress.ctl

'Add a Progress Control, a Timer Control and a Command button on a form
'Copy and paste this code

Option Explicit

Private Sub Command1_Click()

   Command1.Enabled = False
   Progress1.Percent = 0
   Timer1.Enabled = True

End Sub

Private Sub Form_Load()

   Command1.Caption = "Test"
   Timer1.Enabled = False
   Timer1.Interval = 10

End Sub

Private Sub Timer1_Timer()

   If Progress1.Percent = 100 Then
      Timer1.Enabled = False
      Command1.Enabled = True
   Else
      Progress1.Percent = Progress1.Percent + 1
   End If

End Sub

The Code

Progress.ctl

Option Explicit

Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hdcDest As Long, ByVal _
nXDest As Long, ByVal nYDest As Long, ByVal nWidth As Long, ByVal nHeight As _
Long, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal _
dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdc As Long, ByVal x _
As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal hSrcWidth As _
Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Const DEFAULT_FORE_COLOR As Long = 5242880 'RGB(0, 0, 80)
Private Const DEFAULT_BACK_COLOR As Long = &H8000000F  'Button Face

Private Const DEFAULT_FORE_STYLE As Long = 1 'psStretched
Private Const DEFAULT_BACK_STYLE As Long = 2 'psTiled

Public Enum ePictureStyle
   psAutoSized = 0
   psStretched = 1
   psTiled = 2
End Enum

Private mPercent As Long
Private mMax As Long
Private mMin As Long
Private mValue As Long

Private mForeStyle As ePictureStyle
Private mBackStyle As ePictureStyle

Public Property Get ForeStyle() As ePictureStyle

   ForeStyle = mForeStyle
   
End Property

Public Property Let ForeStyle(NewStyle As ePictureStyle)

   mForeStyle = NewStyle
   If mForeStyle = psAutoSized Then
      If mBackStyle = psAutoSized Then
         mBackStyle = DEFAULT_BACK_STYLE
      End If
      UserControl.Width = pctFore.Width
      UserControl.Height = pctFore.Height
   End If
   UserControl_Paint
   
End Property

Public Property Get BackStyle() As ePictureStyle

   BackStyle = mBackStyle
   
End Property

Public Property Let BackStyle(NewStyle As ePictureStyle)

   mBackStyle = NewStyle
   If mBackStyle = psAutoSized Then
      If mForeStyle = psAutoSized Then
         mForeStyle = DEFAULT_FORE_STYLE
      End If
      UserControl_Resize
   End If
   UserControl_Paint
   
End Property

Public Property Get ForePicture() As StdPicture

   Set ForePicture = pctFore.Picture

End Property

Public Property Set ForePicture(NewPicture As StdPicture)

   Set pctFore.Picture = NewPicture
   UserControl_Paint
   PropertyChanged "ForePicture"
   
End Property

Public Property Get BackPicture() As StdPicture

   Set BackPicture = pctBack.Picture

End Property

Public Property Set BackPicture(NewPicture As StdPicture)

   Set pctBack.Picture = NewPicture
   UserControl_Paint
   PropertyChanged "BackPicture"

End Property

Public Property Get BackColor() As OLE_COLOR

   BackColor = UserControl.BackColor

End Property

Public Property Let BackColor(NewBackColor As OLE_COLOR)

   UserControl.BackColor = NewBackColor
   UserControl_Paint
   PropertyChanged "BackColor"
   
End Property

Public Property Get ForeColor() As OLE_COLOR

   ForeColor = UserControl.ForeColor

End Property

Public Property Let ForeColor(NewForeColor As OLE_COLOR)

   UserControl.ForeColor = NewForeColor
   UserControl_Paint
   PropertyChanged "ForeColor"
   
End Property

Public Property Get Percent() As Long

   Percent = mPercent

End Property

Public Property Let Percent(NewPercent As Long)

   If NewPercent < 0 Then
      NewPercent = 0
   End If
   If NewPercent > 100 Then
      NewPercent = 100
   End If
   
   If NewPercent <> mPercent Then
      mPercent = NewPercent
      mValue = Int(((mPercent / 100) * (mMax - mMin)) + mMin)
      UserControl_Paint
   End If
   PropertyChanged "Percent"
   
End Property

Public Property Get Max() As Long

   Max = mMax

End Property

Public Property Let Max(NewMax As Long)

   mMax = NewMax
   
   If mMax < mMin Then
      mMin = mMax
   End If
   UserControl_Paint
   PropertyChanged "Max"
   
End Property

Public Property Get Min() As Long

   Min = mMin

End Property

Public Property Let Min(NewMin As Long)

   mMin = NewMin

   If mMin > mMax Then
      mMax = mMin
   End If
   UserControl_Paint
   PropertyChanged "Min"
   
End Property

Public Property Get Value() As Long

   Value = mValue

End Property

Public Property Let Value(NewValue As Long)

   If NewValue < mMin Then
      mMin = NewValue
   End If
   
   If NewValue > mMax Then
      mMax = NewValue
   End If
   
   mValue = NewValue
   
   If mMax - mMin > 0 Then
      mPercent = Int(((mValue - mMin) / (mMax - mMin)) * 100)
   Else
      mPercent = 0
   End If
   UserControl_Paint
   
End Property

Public Sub About()

   MsgBox "Progress Control By Andrew McMillan" & vbCrLf & vbCrLf & "For more " & _
   "information go to www.paradoxes.info/code", vbInformation, "Progress Control - " & _
   "About"


End Sub

Private Sub UserControl_InitProperties()

   mMax = 100
   UserControl.ForeColor = DEFAULT_FORE_COLOR
   UserControl.BackColor = DEFAULT_BACK_COLOR
   mForeStyle = DEFAULT_FORE_STYLE
   mBackStyle = DEFAULT_BACK_STYLE

End Sub

Private Sub UserControl_Paint()
   
   Dim x As Long
   Dim y As Long

   If pctBack.Picture Is Nothing Then
      pctBuffer.Line (pctBuffer.ScaleLeft, _
      pctBuffer.ScaleTop)-(pctBuffer.ScaleWidth, pctBuffer.ScaleHeight), _
      UserControl.BackColor, BF
   ElseIf pctBack.Picture.Type = vbPicTypeBitmap Then
      If BackStyle = psAutoSized Then
         BitBlt pctBuffer.hdc, pctBuffer.ScaleLeft, pctBuffer.ScaleTop, _
         pctBuffer.ScaleWidth, pctBuffer.ScaleHeight, pctBack.hdc, pctBack.ScaleLeft, _
         pctBack.ScaleTop, vbSrcCopy
      ElseIf BackStyle = psStretched Then
         StretchBlt pctBuffer.hdc, pctBuffer.ScaleLeft, pctBuffer.ScaleTop, _
         pctBuffer.ScaleWidth, pctBuffer.ScaleHeight, pctBack.hdc, pctBack.ScaleLeft, _
         pctBack.ScaleTop, pctBack.ScaleWidth, pctBack.ScaleHeight, vbSrcCopy
      Else 'psTiled (Default)
         For y = 0 To (pctBuffer.ScaleHeight - pctBuffer.ScaleTop) \ _
         (pctBack.ScaleHeight - pctBack.ScaleTop)
            For x = 0 To (pctBuffer.ScaleWidth - pctBuffer.ScaleLeft) \ _
            (pctBack.ScaleWidth - pctBack.ScaleLeft)
               BitBlt pctBuffer.hdc, pctBuffer.ScaleLeft + (x * _
               (pctBack.ScaleWidth - pctBack.ScaleLeft)), pctBuffer.ScaleTop + (y * _
               (pctBack.ScaleHeight - pctBack.ScaleTop)), pctBuffer.ScaleWidth, _
               pctBuffer.ScaleHeight, pctBack.hdc, pctBack.ScaleLeft, pctBack.ScaleTop, _
               vbSrcCopy
            Next
         Next
      End If
   Else
      pctBuffer.Line (pctBuffer.ScaleLeft, _
      pctBuffer.ScaleTop)-(pctBuffer.ScaleWidth, pctBuffer.ScaleHeight), _
      UserControl.BackColor, BF
   End If
   
   If mPercent > 0 Then
      If pctFore.Picture Is Nothing Then
         pctBuffer.Line (pctBuffer.ScaleLeft, _
         pctBuffer.ScaleTop)-(((pctBuffer.ScaleWidth * mPercent) / 100), _
         pctBuffer.ScaleHeight), UserControl.ForeColor, BF
      ElseIf pctFore.Picture.Type = vbPicTypeBitmap Then
         If ForeStyle = psAutoSized Then
            BitBlt pctBuffer.hdc, pctBuffer.ScaleLeft, pctBuffer.ScaleTop, _
            (pctBuffer.ScaleWidth * mPercent) / 100, pctBuffer.ScaleHeight, pctFore.hdc, _
            pctFore.ScaleLeft, pctFore.ScaleTop, vbSrcCopy
         ElseIf ForeStyle = psTiled Then
            For y = 0 To (pctBuffer.ScaleHeight - pctBuffer.ScaleTop) \ _
            (pctFore.ScaleHeight - pctFore.ScaleTop)
               For x = 0 To ((mPercent * (pctBuffer.ScaleWidth - _
               pctBuffer.ScaleLeft)) / 100) \ (pctFore.ScaleWidth - pctFore.ScaleLeft) - 1
                  BitBlt pctBuffer.hdc, pctBuffer.ScaleLeft + (x * _
                  (pctFore.ScaleWidth - pctFore.ScaleLeft)), pctBuffer.ScaleTop + (y * _
                  (pctFore.ScaleHeight - pctFore.ScaleTop)), pctBuffer.ScaleWidth, _
                  pctBuffer.ScaleHeight, pctFore.hdc, pctFore.ScaleLeft, pctFore.ScaleTop, _
                  vbSrcCopy
               Next
               BitBlt pctBuffer.hdc, pctBuffer.ScaleLeft + (x * _
               (pctFore.ScaleWidth - pctFore.ScaleLeft)), pctBuffer.ScaleTop + (y * _
               (pctFore.ScaleHeight - pctFore.ScaleTop)), ((pctBuffer.ScaleWidth * mPercent) / _
               100) - (x * (pctFore.ScaleWidth - pctFore.ScaleLeft)), pctBuffer.ScaleHeight, _
               pctFore.hdc, pctFore.ScaleLeft, pctFore.ScaleTop, vbSrcCopy
            Next
         Else 'psStretched (Default)
            StretchBlt pctBuffer.hdc, pctBuffer.ScaleLeft, pctBuffer.ScaleTop, _
            pctBuffer.ScaleWidth * (mPercent / 100), pctBuffer.ScaleHeight, pctFore.hdc, _
            pctFore.ScaleLeft, pctFore.ScaleTop, pctFore.ScaleWidth, pctFore.ScaleHeight, _
            vbSrcCopy
         End If
      Else
         pctBuffer.Line (pctBuffer.ScaleLeft, _
         pctBuffer.ScaleTop)-(((pctBuffer.ScaleWidth * mPercent) / 100), _
         pctBuffer.ScaleHeight), UserControl.ForeColor, BF
      End If
   End If
   
   BitBlt UserControl.hdc, UserControl.ScaleLeft, UserControl.ScaleTop, _
   UserControl.ScaleWidth, UserControl.ScaleHeight, pctBuffer.hdc, _
   pctBuffer.ScaleLeft, pctBuffer.ScaleTop, vbSrcCopy
   
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

   mMax = PropBag.ReadProperty("Max", 100)
   mMin = PropBag.ReadProperty("Min", 0)
   mValue = PropBag.ReadProperty("Value", 0)
   mPercent = PropBag.ReadProperty("Percent", 0)
   UserControl.BackColor = PropBag.ReadProperty("BackColor", DEFAULT_BACK_COLOR)
   UserControl.ForeColor = PropBag.ReadProperty("ForeColor", DEFAULT_FORE_COLOR)
   Set pctFore.Picture = PropBag.ReadProperty("ForePicture", Nothing)
   Set pctBack.Picture = PropBag.ReadProperty("BackPicture", Nothing)
   mForeStyle = PropBag.ReadProperty("ForeStyle", DEFAULT_FORE_STYLE)
   mBackStyle = PropBag.ReadProperty("BackStyle", DEFAULT_BACK_STYLE)
   
End Sub

Private Sub UserControl_Resize()

   pctBuffer.Move 0, 0, UserControl.Width / Screen.TwipsPerPixelX, _
   UserControl.Height / Screen.TwipsPerPixelY
   If ForeStyle = psAutoSized Then
      If Not pctFore.Picture Is Nothing Then
         If pctFore.Picture.Type = vbPicTypeBitmap Then
            UserControl.Width = (pctFore.Width * Screen.TwipsPerPixelX) + _
            (UserControl.Width - (Screen.TwipsPerPixelX * (UserControl.ScaleWidth + _
            UserControl.ScaleLeft)))
            UserControl.Height = (pctFore.Height * Screen.TwipsPerPixelY) + _
            (UserControl.Height - (Screen.TwipsPerPixelY * (UserControl.ScaleHeight + _
            UserControl.ScaleTop)))
         End If
      End If
   End If
   If BackStyle = psAutoSized Then
      If Not pctBack.Picture Is Nothing Then
         If pctBack.Picture.Type = vbPicTypeBitmap Then
            UserControl.Width = (pctBack.Width * Screen.TwipsPerPixelX) + _
            (UserControl.Width - (Screen.TwipsPerPixelX * (UserControl.ScaleWidth + _
            UserControl.ScaleLeft)))
            UserControl.Height = (pctBack.Height * Screen.TwipsPerPixelY) + _
            (UserControl.Height - (Screen.TwipsPerPixelY * (UserControl.ScaleHeight + _
            UserControl.ScaleTop)))
         End If
      End If
   End If

End Sub

Private Sub UserControl_Terminate()

   Set pctFore.Picture = Nothing
   Set pctBack.Picture = Nothing

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

   PropBag.WriteProperty "Max", mMax, 100
   PropBag.WriteProperty "Min", mMin, 0
   PropBag.WriteProperty "Value", mValue, 0
   PropBag.WriteProperty "Percent", mPercent, 0
   PropBag.WriteProperty "BackColor", UserControl.BackColor, DEFAULT_BACK_COLOR
   PropBag.WriteProperty "ForeColor", UserControl.ForeColor, DEFAULT_FORE_COLOR
   PropBag.WriteProperty "ForePicture", pctFore.Picture, Nothing
   PropBag.WriteProperty "BackPicture", pctBack.Picture, Nothing
   PropBag.WriteProperty "ForeStyle", mForeStyle, DEFAULT_FORE_STYLE
   PropBag.WriteProperty "BackStyle", mBackStyle, DEFAULT_BACK_STYLE
   
End Sub

Downloads

ProgressControl.zip - contains: Progress.ctl, Progress.ctx (3 kb)

ProgressProject.zip - An example of the Progress Control in use (18 kb)

Unless otherwise stated, the code on this site is Copyright to Andrew McMillan. You may use this code in your projects (both commercial and non-commercial) but you are not permitted to republish this code in any form without the Author's prior consent.

The code on this site is supplied "as is" and no claims are made as to its soundness. The Author claims no responsibility for or liability from use of said source code.

Home

Comments

Reference

Usage

The Code

Downloads

© Copyright Notice