www.pudn.com > progressbar.rar > CoolProgressBar_Ocx.ctl, change:2000-09-27,size:16788b


VERSION 5.00 
Begin VB.UserControl CoolProgressBar  
   ClientHeight    =   240 
   ClientLeft      =   0 
   ClientTop       =   0 
   ClientWidth     =   3840 
   ScaleHeight     =   16 
   ScaleMode       =   3  'Pixel 
   ScaleWidth      =   256 
   ToolboxBitmap   =   "CoolProgressBar_Ocx.ctx":0000 
   Begin VB.PictureBox picBackbuffer  
      AutoRedraw      =   -1  'True 
      BackColor       =   &H00000000& 
      BorderStyle     =   0  'None 
      Height          =   255 
      Left            =   0 
      ScaleHeight     =   255 
      ScaleWidth      =   3840 
      TabIndex        =   0 
      Top             =   0 
      Visible         =   0   'False 
      Width           =   3840 
   End 
End 
Attribute VB_Name = "CoolProgressBar" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = True 
Attribute VB_PredeclaredId = False 
Attribute VB_Exposed = True 
 
' 
'(Cool Progress Bar by Jotaf98) ____________________ 
' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ 
' Read "Readme.txt" for more details. 
' 
' 
'(Contact - E-mail: jotaf98@hotmail.com) ___________ 
' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ 
' 
 
Option Explicit 
 
'Default Property Values: 
Const m_def_Orientation = 0 
Const m_def_Value = 100 
Const m_def_Min = 0 
Const m_def_Max = 100 
Const m_def_Color2 = 16777215 
Const m_def_Color1 = 16711680 
'Property Variables: 
Dim m_Orientation As Integer 
Dim m_Value As Integer 
Dim m_Min As Integer 
Dim m_Max As Integer 
Dim m_Color2 As Long 
Dim m_Color1 As Long 
'Event Declarations: 
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click 
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object." 
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick 
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object." 
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown 
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus." 
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove 
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse." 
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp 
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus." 
 
'APIs 
 
'Draws a pixel (used to draw the grad effect) 
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long 
 
'After drawing the grad to the backbuffer, StretchBlt 
'will stretch it to fit the control (still in the 
'backbuffer) 
Private Declare Function StretchBlt Lib "gdi32" (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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long 
 
'Then, when it's needed, copy it to the control using 
'BitBlt 
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long 
 
 
'If the grad has already been drawn or not 
Dim GradDone As Boolean 
 
'The Alpha - the translucency level between the 
'first color and the second color. 
Dim Alpha As Integer 
 
'First color's RGB values 
Dim bc_Red1 As Byte 
Dim bc_Green1 As Byte 
Dim bc_Blue1 As Byte 
 
'Second color's RGB values 
Dim bc_Red2 As Byte 
Dim bc_Green2 As Byte 
Dim bc_Blue2 As Byte 
 
'Final RGB values 
Dim bc_RedF As Integer 
Dim bc_GreenF As Integer 
Dim bc_BlueF As Integer 
 
'When figuring out the bar's width/height based on 
'Max, Min and Value, it will be stored here. 
Dim TempSize As Integer 
 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MappingInfo=UserControl,UserControl,-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 = UserControl.BackColor 
End Property 
 
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR) 
    UserControl.BackColor() = New_BackColor 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint the control 
    UserControl_Paint 
     
    PropertyChanged "BackColor" 
End Property 
 
'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." 
    Enabled = UserControl.Enabled 
End Property 
 
Public Property Let Enabled(ByVal New_Enabled As Boolean) 
    UserControl.Enabled() = New_Enabled 
    PropertyChanged "Enabled" 
End Property 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MappingInfo=UserControl,UserControl,-1,BorderStyle 
Public Property Get BorderStyle() As Integer 
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object." 
    BorderStyle = UserControl.BorderStyle 
End Property 
 
Public Property Let BorderStyle(ByVal New_BorderStyle As Integer) 
    UserControl.BorderStyle() = New_BorderStyle 
    PropertyChanged "BorderStyle" 
End Property 
 
'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." 
    UserControl.Refresh 
End Sub 
 
Private Sub UserControl_Click() 
    RaiseEvent Click 
End Sub 
 
Private Sub UserControl_DblClick() 
    RaiseEvent DblClick 
End Sub 
 
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 
    RaiseEvent MouseDown(Button, Shift, x, y) 
End Sub 
 
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 
    RaiseEvent MouseMove(Button, Shift, x, y) 
End Sub 
 
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 
    RaiseEvent MouseUp(Button, Shift, x, y) 
End Sub 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=10,0,0,16777215 
Public Property Get Color2() As OLE_COLOR 
Attribute Color2.VB_Description = "This is the second color in the gradient effect." 
    Color2 = m_Color2 
End Property 
 
Public Property Let Color2(ByVal New_Color2 As OLE_COLOR) 
    m_Color2 = New_Color2 
     
    'Convert the new color to RGB 
    ConvertToRGB 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint the control 
    UserControl_Paint 
     
    PropertyChanged "Color2" 
End Property 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=10,0,0,16711680 
Public Property Get Color1() As OLE_COLOR 
Attribute Color1.VB_Description = "This is the first color in the gradient effect." 
    Color1 = m_Color1 
End Property 
 
Public Property Let Color1(ByVal New_Color1 As OLE_COLOR) 
    m_Color1 = New_Color1 
     
    'Convert the new color to RGB 
    ConvertToRGB 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint the control 
    UserControl_Paint 
     
    PropertyChanged "Color1" 
End Property 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=7,0,0,0 
Public Property Get Orientation() As Integer 
    Orientation = m_Orientation 
End Property 
 
Public Property Let Orientation(ByVal New_Orientation As Integer) 
    m_Orientation = New_Orientation 
     
    'Only accept 0 (Horizontal) or 1 (Vertical) 
    If m_Orientation <> 0 And m_Orientation <> 1 Then 
        m_Orientation = 0 
    End If 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint the control 
    UserControl_Paint 
     
    PropertyChanged "Orientation" 
End Property 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=7,0,0,100 
Public Property Get Value() As Integer 
    Value = m_Value 
End Property 
 
Public Property Let Value(ByVal New_Value As Integer) 
    m_Value = New_Value 
     
    'Can't have a value greater than max or smaller than min 
    If m_Value > m_Max Then m_Value = m_Max 
    If m_Value < m_Min Then m_Value = m_Min 
     
    PropertyChanged "Value" 
     
    'Repaint 
    UserControl_Paint 
End Property 
 
'Initialize Properties for User Control 
Private Sub UserControl_InitProperties() 
    m_Color2 = m_def_Color2 
    m_Color1 = m_def_Color1 
    m_Min = m_def_Min 
    m_Max = m_def_Max 
    m_Orientation = m_def_Orientation 
    m_Value = m_def_Value 
End Sub 
 
'Load property values from storage 
Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 
 
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F) 
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True) 
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0) 
    m_Color2 = PropBag.ReadProperty("Color2", m_def_Color2) 
    m_Color1 = PropBag.ReadProperty("Color1", m_def_Color1) 
    m_Min = PropBag.ReadProperty("Min", m_def_Min) 
    m_Max = PropBag.ReadProperty("Max", m_def_Max) 
    m_Orientation = PropBag.ReadProperty("Orientation", m_def_Orientation) 
    m_Value = PropBag.ReadProperty("Value", m_def_Value) 
End Sub 
 
Private Sub UserControl_Resize() 
    If Not GradDone Then Exit Sub 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint the control 
    UserControl_Paint 
End Sub 
 
Private Sub UserControl_Initialize() 
    'This will fix a really weird bug - try 
    'commenting these lines and creating a 
    'progress bar by double-clicking its 
    'icon to see what I mean! 
    UserControl.Width = UserControl.Width + 60 
    UserControl.Height = 255 
End Sub 
 
'Write property values to storage 
Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 
 
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F) 
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True) 
    Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0) 
    Call PropBag.WriteProperty("Color2", m_Color2, m_def_Color2) 
    Call PropBag.WriteProperty("Color1", m_Color1, m_def_Color1) 
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min) 
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max) 
    Call PropBag.WriteProperty("Orientation", m_Orientation, m_def_Orientation) 
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value) 
End Sub 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=7,0,0,0 
Public Property Get Min() As Integer 
    Min = m_Min 
End Property 
 
Public Property Let Min(ByVal New_Min As Integer) 
    m_Min = New_Min 
     
    'Can't use a Min greater or equal to Max! 
    If m_Min >= m_Max Then 
        MsgBox """Min"" must be smaller than ""Max"".", , "Error" 
        m_Min = m_Max - 1 
    End If 
     
    'If the Value is smaller than Min, set it to Min 
    If m_Value < m_Min Then 
        m_Value = m_Min 
    End If 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint 
    UserControl_Paint 
     
    PropertyChanged "Min" 
End Property 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES! 
'MemberInfo=7,0,0,100 
Public Property Get Max() As Integer 
    Max = m_Max 
End Property 
 
Public Property Let Max(ByVal New_Max As Integer) 
    m_Max = New_Max 
     
    'Can't use a Max smaller or equal to Min! 
    If m_Max <= m_Min Then 
        MsgBox """Max"" must be greater than ""Min"".", , "Error" 
        m_Max = m_Min + 1 
    End If 
     
    'If the Value is greater than Max, set it to Max 
    If m_Value > m_Max Then 
        m_Value = m_Max 
    End If 
     
    'Redraw the grad effect 
    DrawGrad 
     
    'Repaint 
    UserControl_Paint 
     
    PropertyChanged "Max" 
End Property 
 
'This is the most important sub - it draws the control 
Private Sub UserControl_Paint() 
    'If the grad is not already drawn, draw it 
    If GradDone = False Then DrawGrad 
     
    'Calculate TempSize horizontally or vertically, depending 
    'on the Orientation property 
    If m_Orientation = 0 Then '<Horizontal> 
        'This will get the width of the bar based on the value 
        TempSize = ScaleWidth / (m_Max - m_Min) * m_Value 
         
        'Clear the control and copy the grad to it, according to 
        'the new width of the bar 
        Cls 
        BitBlt hdc, 0, 0, TempSize, ScaleHeight, picBackbuffer.hdc, 0, 0, vbSrcCopy 
    ElseIf m_Orientation = 1 Then '<Vertical> 
        'This will get the height of the bar based on the value 
        TempSize = ScaleHeight / (m_Max - m_Min) * (m_Max - m_Value) 
         
        'Clear the control and copy the grad to it, according to 
        'the new width of the bar 
        Cls 
        BitBlt hdc, 0, TempSize, ScaleWidth, ScaleHeight - TempSize, picBackbuffer.hdc, 0, TempSize, vbSrcCopy 
    End If 
End Sub 
 
'Will draw the grad effect to picBackbuffer so whenever 
'we need to draw the bar, we just copy the part we need 
'from it 
Private Sub DrawGrad() 
    'Counter 
    Dim i As Integer 
     
    'Convert the colors to RGB 
    ConvertToRGB 
     
    'Resize the backbuffer to make sure the bar fits in it 
    picBackbuffer.Move 0, 0, ScaleWidth, ScaleHeight 
     
    'Draw horizontally or vertically, depending on the 
    'Orientation property 
    If m_Orientation = 0 Then '<Horizontal> 
        'Loop trough all possible grad colors 
        For i = 0 To 255 
            'Set the Alpha to the current counter value 
            Alpha = i 
             
            'Blend the colors 
            BlendColors 
             
            'Draw the new pixel 
            SetPixelV picBackbuffer.hdc, i, 0, RGB(bc_RedF, bc_GreenF, bc_BlueF) 
        Next i 
         
        'Stretch the tiny line we have drawn to fit the 
        'control 
        StretchBlt picBackbuffer.hdc, 0, 0, ScaleWidth, ScaleHeight, picBackbuffer.hdc, 0, 0, 255, 1, vbSrcCopy 
    ElseIf m_Orientation = 1 Then '<Vertical> 
        'Loop trough all possible grad colors 
        For i = 0 To 255 
            'Set the Alpha to [255 - the current counter 
            'value] (this will make it so Color1 is at 
            'the bottom and Color2 at the top) 
            Alpha = 255 - i 
             
            'Blend the colors 
            BlendColors 
             
            'Draw the new pixel 
            SetPixelV picBackbuffer.hdc, 0, i, RGB(bc_RedF, bc_GreenF, bc_BlueF) 
        Next i 
         
        'Stretch the tiny line we have drawn to fit the 
        'control 
        StretchBlt picBackbuffer.hdc, 0, 0, ScaleWidth, ScaleHeight, picBackbuffer.hdc, 0, 0, 1, 255, vbSrcCopy 
    End If 
     
    'Grad done 
    GradDone = True 
End Sub 
 
' 
'(Functions for the grad effect) ___________________ 
' ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ 
' 
 
'Gets a grad between 2 colors (the results now are in 
'"bc_[Red/Green/Blue]F") 
Private Sub BlendColors() 
    'Find the difference between Red 1 and Red 2. 
    If bc_Red2 > bc_Red1 Then 
        bc_RedF = bc_Red2 - bc_Red1 
    Else 
        bc_RedF = bc_Red1 - bc_Red2 
        bc_RedF = -bc_RedF 
    End If 
     
    'This is the core function for Red 
    bc_RedF = bc_RedF / 256 * Alpha + bc_Red1 
     
    'Find the difference between Green 1 and Green 2. 
    If bc_Green2 > bc_Green1 Then 
        bc_GreenF = bc_Green2 - bc_Green1 
    Else 
        bc_GreenF = bc_Green1 - bc_Green2 
        bc_GreenF = -bc_GreenF 
    End If 
     
    'This is the core function for Green 
    bc_GreenF = bc_GreenF / 256 * Alpha + bc_Green1 
     
    'Find the difference between Blue 1 and Blue 2. 
    If bc_Blue2 > bc_Blue1 Then 
        bc_BlueF = bc_Blue2 - bc_Blue1 
    Else 
        bc_BlueF = bc_Blue1 - bc_Blue2 
        bc_BlueF = -bc_BlueF 
    End If 
     
    'This is the core function for Blue 
    bc_BlueF = bc_BlueF / 256 * Alpha + bc_Blue1 
End Sub 
 
'Converts the Long colors to RGB values 
Private Sub ConvertToRGB() 
    bc_Red1 = m_Color1 And 255 
    bc_Green1 = (m_Color1 And 65280) \ 256 
    bc_Blue1 = (m_Color1 And 16711680) \ 65535 
     
    bc_Red2 = m_Color2 And 255 
    bc_Green2 = (m_Color2 And 65280) \ 256 
    bc_Blue2 = (m_Color2 And 16711680) \ 65535 
End Sub