mkcProgressBar.ctl

 VERSION 5.00
Begin VB.UserControl mkcProgressBar
   ClientHeight    =   375
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3375
   PropertyPages   =   "mkcProgressBar.ctx":0000
   ScaleHeight     =   375
   ScaleWidth      =   3375
   ToolboxBitmap   =   "mkcProgressBar.ctx":003B
   Begin VB.PictureBox picProgress
      AutoRedraw      =   -1  'True
      FillStyle       =   0  'Solid
      Height          =   375
      Left            =   0
      ScaleHeight     =   315
      ScaleWidth      =   3315
      TabIndex        =   0
      Top             =   0
      Width           =   3375
      Begin VB.Label lblProgress
         Alignment       =   2  'Center
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "0%"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   195
         Left            =   0
         TabIndex        =   1
         Top             =   0
         Visible         =   0   'False
         Width           =   270
      End
   End
End
Attribute VB_Name = "mkcProgressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'============================================================================================
' mkcProgressBar Control
'============================================================================================
' Created By: Marc Cramer
' Published Date: 01/01/2001
' WebSite: MKC Computers at http://www.mkccomputers.com
'============================================================================================
' Additional Reference: vbAccelerator Multi-Threading In-Progress Control  (vbalIPrg.dll)
' WebSite Downloaded From: VBAccelerator at http://www.vbaccelerator.com
'============================================================================================
Option Explicit
'Enums
Public Enum Appearance
    Flat = 0
    [3D] = 1
End Enum
Public Enum BorderStyle
    None = 0
    [Fixed Single] = 1
End Enum
Public Enum DisplayStyle
    Normal = 0
    Smooth = 1
    Bouncing = 2
End Enum
' My Variables
Dim MyBouncer As cInProgress
Dim Counter As Integer
Dim MyCaption As String
'Default Property Values:
Const m_def_Value = 0
Const m_def_DisplayStyle = 0
Const m_def_BarPercentage = 5
Const m_def_Min = 0
Const m_def_Max = 100
Const m_def_ProgressColor = &HFF0000
'Property Variables:
Dim m_Value As Integer
Dim m_DisplayStyle As Byte
Dim m_BarPercentage As Byte
Dim m_Min As Integer
Dim m_Max As Integer
Dim m_ProgressColor As OLE_COLOR
'Event Declarations:
Event InitProperties() 'MappingInfo=UserControl,UserControl,-1,InitProperties
Attribute InitProperties.VB_Description = "Occurs the first time a user control or user document is created."
Event ReadProperties(PropBag As PropertyBag) 'MappingInfo=UserControl,UserControl,-1,ReadProperties
Attribute ReadProperties.VB_Description = "Occurs when a user control or user document is asked to read its data from a file."
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize
Attribute Resize.VB_Description = "Occurs when a form is first displayed or the size of an object changes."
Event WriteProperties(PropBag As PropertyBag) 'MappingInfo=UserControl,UserControl,-1,WriteProperties
Attribute WriteProperties.VB_Description = "Occurs when a user control or user document is asked to write its data to a file."
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=picProgress,picProgress,-1,Appearance
Public Property Get Appearance() As Appearance
Attribute Appearance.VB_Description = "Returns/sets whether or not an object is painted at run time with 3-D effects."
  Appearance = picProgress.Appearance
End Property 'Get Appearance() As Appearance
'============================================================================================
Public Property Let Appearance(ByVal New_Appearance As Appearance)
  picProgress.Appearance() = New_Appearance
  PropertyChanged "Appearance"
End Property 'Let Appearance(ByVal New_Appearance As Appearance)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=picProgress,picProgress,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
  BackColor = picProgress.BackColor
End Property 'Get BackColor() As OLE_COLOR
'============================================================================================
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
' set all backcolors the same
  picProgress.BackColor() = New_BackColor
  UserControl.BackColor() = New_BackColor
  lblProgress.BackColor() = New_BackColor
  PropertyChanged "BackColor"
End Property 'Let BackColor(ByVal New_BackColor As OLE_COLOR)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=picProgress,picProgress,-1,BorderStyle
Public Property Get BorderStyle() As BorderStyle
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
  BorderStyle = picProgress.BorderStyle
End Property 'Get BorderStyle() As BorderStyle
'============================================================================================
Public Property Let BorderStyle(ByVal New_BorderStyle As BorderStyle)
  picProgress.BorderStyle() = New_BorderStyle
  PropertyChanged "BorderStyle"
End Property 'Let BorderStyle(ByVal New_BorderStyle As BorderStyle)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
Attribute Enabled.VB_ProcData.VB_Invoke_Property = "OtherSettings"
  Enabled = UserControl.Enabled
End Property 'Get Enabled() As Boolean
'============================================================================================
Public Property Let Enabled(ByVal New_Enabled As Boolean)
' set all enabled the same
  UserControl.Enabled() = New_Enabled
  picProgress.Enabled() = New_Enabled
  lblProgress.Enabled() = New_Enabled
  PropertyChanged "Enabled"
End Property 'Let Enabled(ByVal New_Enabled As Boolean)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lblProgress,lblProgress,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
  Set Font = lblProgress.Font
End Property 'Get Font() As Font
'============================================================================================
Public Property Set Font(ByVal New_Font As Font)
' set the fonts all the same
  Set lblProgress.Font = New_Font
  Set picProgress.Font = New_Font
  Set UserControl.Font = New_Font
  PropertyChanged "Font"
End Property 'Set Font(ByVal New_Font As Font)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=lblProgress,lblProgress,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
  ForeColor = lblProgress.ForeColor
End Property 'Get ForeColor() As OLE_COLOR
'============================================================================================
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
' set all the forecolors the same
  lblProgress.ForeColor() = New_ForeColor
  UserControl.ForeColor() = New_ForeColor
  picProgress.ForeColor() = New_ForeColor
  PropertyChanged "ForeColor"
End Property 'Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,hWnd
Public Property Get hwnd() As Long
Attribute hwnd.VB_Description = "Returns a handle (from Microsoft Windows) to an object's window."
  hwnd = UserControl.hwnd
End Property 'Get hwnd() As Long
'============================================================================================
Private Sub UserControl_Initialize()
' create instance of bouncing progress bar
  Set MyBouncer = New cInProgress
  With MyBouncer
    .Steps = 32
    .StepSize = 4
    .AnimStepSize = 4
    .StartCol = ProgressColor
    .EndCol = BackColor
    .hwnd = picProgress.hwnd
  End With
End Sub 'UserControl_Initialize()
'============================================================================================
Private Sub UserControl_InitProperties()
  RaiseEvent InitProperties
  m_DisplayStyle = m_def_DisplayStyle
  m_BarPercentage = m_def_BarPercentage
  m_Min = m_def_Min
  m_Max = m_def_Max
  m_ProgressColor = m_def_ProgressColor
  m_Value = m_def_Value
 
  ' set values to initial values...just to be sure
  Appearance = [3D]
  BarPercentage = 5
  BorderStyle = [Fixed Single]
  DisplayStyle = Normal
  ProgressColor = &HFF0000
  lblProgress.Font = "MS Sans Serif"
  lblProgress.FontBold = True
  lblProgress.ForeColor = &HFFFFFF
  BackColor = &H8000000F
  Min = 0
  Max = 100
  Value = 0
End Sub 'UserControl_InitProperties()
'============================================================================================
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  RaiseEvent ReadProperties(PropBag)
  picProgress.Appearance = PropBag.ReadProperty("Appearance", 1)
  picProgress.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
  picProgress.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  Set lblProgress.Font = PropBag.ReadProperty("Font", Ambient.Font)
  lblProgress.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
  m_DisplayStyle = PropBag.ReadProperty("DisplayStyle", m_def_DisplayStyle)
  m_BarPercentage = PropBag.ReadProperty("BarPercentage", m_def_BarPercentage)
  m_Min = PropBag.ReadProperty("Min", m_def_Min)
  m_Max = PropBag.ReadProperty("Max", m_def_Max)
  m_ProgressColor = PropBag.ReadProperty("ProgressColor", m_def_ProgressColor)
  m_Value = PropBag.ReadProperty("Value", m_def_Value)
End Sub 'UserControl_ReadProperties(PropBag As PropertyBag)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
' refresh all controls and do events
  lblProgress.Refresh
  picProgress.Refresh
  UserControl.Refresh
  DoEvents
End Sub 'Refresh()
'============================================================================================
Private Sub UserControl_Resize()
' resize picProgress to usercontrol size and center lblProgress
  picProgress.Move 0, 0, UserControl.Width, UserControl.Height
  lblProgress.Move ((picProgress.ScaleWidth / 2) - (lblProgress.Width / 2)), ((picProgress.ScaleHeight / 2) - (lblProgress.Height / 2))
  RaiseEvent Resize
End Sub 'UserControl_Resize()
'============================================================================================
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  RaiseEvent WriteProperties(PropBag)
  Call PropBag.WriteProperty("Appearance", picProgress.Appearance, 1)
  Call PropBag.WriteProperty("BackColor", picProgress.BackColor, &H8000000F)
  Call PropBag.WriteProperty("BorderStyle", picProgress.BorderStyle, 0)
  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  Call PropBag.WriteProperty("Font", lblProgress.Font, Ambient.Font)
  Call PropBag.WriteProperty("ForeColor", lblProgress.ForeColor, &H80000012)
  Call PropBag.WriteProperty("DisplayStyle", m_DisplayStyle, m_def_DisplayStyle)
  Call PropBag.WriteProperty("BarPercentage", m_BarPercentage, m_def_BarPercentage)
  Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
  Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
  Call PropBag.WriteProperty("ProgressColor", m_ProgressColor, m_def_ProgressColor)
  Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
End Sub 'UserControl_WriteProperties(PropBag As PropertyBag)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=1,0,0,0
Public Property Get DisplayStyle() As DisplayStyle
  DisplayStyle = m_DisplayStyle
End Property 'Get DisplayStyle() As DisplayStyle
'============================================================================================
Public Property Let DisplayStyle(ByVal New_DisplayStyle As DisplayStyle)
' if bouncing then don't show lblProgress
  m_DisplayStyle = New_DisplayStyle
  If m_DisplayStyle <> Bouncing Then
    lblProgress.Visible = True
  Else
    lblProgress.Visible = False
  End If
  PropertyChanged "DisplayStyle"
End Property 'Let DisplayStyle(ByVal New_DisplayStyle As DisplayStyle)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=1,0,0,5
Public Property Get BarPercentage() As Integer
Attribute BarPercentage.VB_Description = "The percent amount that will be displayed by one block when DisplayStyle is Normal"
Attribute BarPercentage.VB_ProcData.VB_Invoke_Property = "OtherSettings"
  BarPercentage = m_BarPercentage
End Property 'Get BarPercentage() As Integer
'============================================================================================
Public Property Let BarPercentage(ByVal New_BarPercentage As Integer)
  m_BarPercentage = New_BarPercentage
  PropertyChanged "BarPercentage"
End Property 'Let BarPercentage(ByVal New_BarPercentage As Integer)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get Min() As Integer
Attribute Min.VB_Description = "Minimum value of the progress bar"
Attribute Min.VB_ProcData.VB_Invoke_Property = "OtherSettings"
  Min = m_Min
End Property 'Get Min() As Integer
'============================================================================================
Public Property Let Min(ByVal New_Min As Integer)
  m_Min = New_Min
  PropertyChanged "Min"
End Property 'Let Min(ByVal New_Min As Integer)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,100
Public Property Get Max() As Integer
Attribute Max.VB_Description = "Maximum value of the progress bar"
Attribute Max.VB_ProcData.VB_Invoke_Property = "OtherSettings"
  Max = m_Max
End Property 'Get Max() As Integer
'============================================================================================
Public Property Let Max(ByVal New_Max As Integer)
  m_Max = New_Max
  PropertyChanged "Max"
End Property 'Let Max(ByVal New_Max As Integer)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get ProgressColor() As OLE_COLOR
Attribute ProgressColor.VB_Description = "Progress indicator color"
  ProgressColor = m_ProgressColor
End Property 'Get ProgressColor() As OLE_COLOR
'============================================================================================
Public Property Let ProgressColor(ByVal New_ProgressColor As OLE_COLOR)
  m_ProgressColor = New_ProgressColor
  PropertyChanged "ProgressColor"
End Property 'Let ProgressColor(ByVal New_ProgressColor As OLE_COLOR)
'============================================================================================
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get Value() As Single
Attribute Value.VB_Description = "Amount to increment the progress bar"
Attribute Value.VB_ProcData.VB_Invoke_Property = "OtherSettings"
  Value = m_Value
End Property 'Get Value() As Single
'============================================================================================
Public Property Let Value(ByVal New_Value As Single)
' update progress bar value
  m_Value = New_Value
  PropertyChanged "Value"
  MyCaption = CStr(CInt(100 * Value / Max)) & "%"
  Select Case DisplayStyle
  Case 0, 1:
    If Value > Max Then Value = Max
    If Value < Min Then Value = Min
    lblProgress.Visible = True
    lblProgress.Caption = MyCaption
    If DisplayStyle = Normal Then
      NormalDisplay
    Else
      SmoothDisplay
    End If
    Refresh
  Case 2:
    BouncingDisplay
  End Select
End Property 'Let Value(ByVal New_Value As Single)
'============================================================================================
Private Sub BouncingDisplay()
' bouncing so set start and end colors
' If not min or max value then keep bouncing
  lblProgress.Visible = False
  With MyBouncer
    .StartCol = CLng(ProgressColor)
    .EndCol = CLng(BackColor)
    If Value < Max And Value > Min Then
      .Running = True
    Else
      .Running = False
    End If
  End With
End Sub 'BouncingDisplay()
'============================================================================================
Private Sub SmoothDisplay()
' smooth display so update progress bar display
  Dim OldScaleWidth As Single
  OldScaleWidth = picProgress.ScaleWidth
  picProgress.ScaleWidth = 100
  With picProgress
    picProgress.Line (0, 0)-((100 * Value / Max), picProgress.ScaleHeight), ProgressColor, BF
  End With
  picProgress.ScaleWidth = OldScaleWidth
End Sub 'SmoothDisplay()
'============================================================================================
Private Sub NormalDisplay()
' normal display so update progress bar display...need to clear display each time
' so paints a solid line set at backcolor used to keep display accurate
' (picProgress.Cls is no longer supported in VBNET)
  Dim TempCounter As Integer
  Dim OldFillColor As Long
  Dim TempNumber As Single
  Dim TempWidth As Single
  Dim TempHeight As Single

  TempNumber = picProgress.ScaleWidth / (picProgress.ScaleWidth * (BarPercentage * 0.01))
  TempWidth = (picProgress.ScaleWidth - 10) / TempNumber
  TempHeight = picProgress.ScaleHeight - 10
  OldFillColor = CLng(picProgress.FillColor)
  picProgress.FillColor = ProgressColor
  If Value > 0 And Value Mod BarPercentage = 0 Then
    picProgress.Line (0, 0)-(picProgress.ScaleWidth, picProgress.ScaleHeight), BackColor, BF
    picProgress.CurrentX = 0
    picProgress.CurrentY = 0
    For TempCounter = 0 To Counter
      picProgress.Line (picProgress.CurrentX, TempHeight)-(picProgress.CurrentX + TempWidth, picProgress.CurrentY), picProgress.BackColor, B
    Next TempCounter
    Counter = Counter + 1
  End If
  picProgress.FillColor = OldFillColor
End Sub 'NormalDisplay()
'============================================================================================
Public Sub Reset()
' general reset and clean up procedure
  MyBouncer.Running = False
  Value = 0
  Counter = 0
  lblProgress.Visible = False
  picProgress.Line (0, 0)-(picProgress.ScaleWidth, picProgress.ScaleHeight), picProgress.BackColor, BF
  Refresh
End Sub 'Reset()
'============================================================================================

Project Homepage: