tvate.ctl

非常漂亮的滑动条源代码

VERSION 5.00
Begin VB.UserControl tVate 
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000005&
   ClientHeight    =   2865
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   6075
   DrawMode        =   10  'Mask Pen
   ScaleHeight     =   2865
   ScaleWidth      =   6075
   ToolboxBitmap   =   "tVate.ctx":0000
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   990
      Top             =   495
   End
End
Attribute VB_Name = "tVate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'绘图方案： 图片高度一定要相同 ，  左角图片，右角图片，左渐变图片，右渐变图片，中间按钮图片（正常，鼠标经过，鼠标按下,透明处理图片），

'


Private Type sColor
    Red As Integer
    Green As Integer
    Blue As Integer
End Type

Const MERGEPAINT = &HBB0226
Const SRCAND = &H8800C6
'

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'获取鼠标位置
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Type PointAPI
    X As Long
    Y As Long
End Type

Const MILLICMETERCELL = 26.45836 '每一个像素点相当于多少微米
Const JIANJU = 200

Public Enum sStyle
   ' 进度条_0 = 0    '进度条模式 没有图片的
    进度条_1 = 1    '滑动条模式,没有图片的
    滑动条_2 = 2   '滑动条模式2，由图片充当渐变色
    两张图片重叠_3 = 3   '滑动条模式3,两张图片重叠_3
End Enum

Public Enum sMouseState
    M_Up = 0
    M_Over = 1
    M_Down = 2
    M_Enabled = 3
End Enum

'图片变量
Private cLPicture           As StdPicture         '该图片作用于显示圆角，像那些播放器就有这样的图片，左半边的图片贴在左边，右边的贴在右边
Private cRPicture           As StdPicture

Private cLMPicture          As StdPicture         '滑动条没走过的图片，通过放大处理该图片,一般代表渐变色(注：如果Style设置为 图片重叠模式 那么 就用这两个图片重叠)
Private cRMPicture          As StdPicture         '滑动条已走过的图片

Private cmdPic              As StdPicture         '中间的滑动按钮图片，绘图方案：正常，经过，按下，禁止

Private cmP_W               As Integer            '中间图片的宽度
Private cmP_H               As Integer            '滑块的高度
Private cmP_T               As Integer            '滑块的Top位置



Private clP_W               As Integer            '左边图片的宽度
Private crP_W               As Integer            '右边图片的宽度







'Private cBkPicture          As StdPicture         '用于背景的图片

Private AColor              As OLE_COLOR               '滑动条还没走过的地方的渐变色A
Private BColor              As OLE_COLOR               '滑动条还没走过的地方的渐变色B
Private gotAColor           As OLE_COLOR               '滑动条已经走过地方的渐变颜色A
Private gotBColor           As OLE_COLOR               '滑动条已经走过的渐变色B

Private cMax                As Long               '最大值
Private cValue              As Long               '值
Private cStyle              As sStyle             '控件样式
Private cmdState            As sMouseState        '滑动块鼠标状态

Private cCaption            As String             '文本



Private cmp_X               As Single             '滑动块的X轴
Private MX                  As Single             '当前鼠标在控件上的X位置

Private cCanMove            As Boolean            '是否允许在鼠标按下或移动时值改变
Private IsDown              As Boolean            '鼠标现在状态是否为按下
Private IsOver              As Boolean
Private LastButton          As Integer            '最后按下的鼠标键

Private cIsShowCmd          As Boolean            '判断是否显示中间的滑动按钮

'Private cCanTransparent     As Boolean           '判断图片是否能用透明模式

Private cBite_LP             As Integer           '减去一截位置
Private cBite_RP             As Integer

Public Event MouseOverCmd()
Public Event MouseOutCmd()
Public Event Changed(tValue As Long, tMax As Long)
Public Event Done(tValue As Long, tMax As Long)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event Click()
Public Event DBClick()

'******************************************   属性   *************************************************!
'**                                                                                                  **
'**                                                                                                  **
'**                                                                                                  **


Public Property Get Caption() As String
    Caption = cCaption
End Property

Public Property Let Caption(ByVal newValue As String)
    cCaption = newValue
    PropertyChanged ("Caption")
End Property

Public Property Get Hwnd() As Long
    Hwnd = UserControl.Hwnd
End Property

Public Property Get cMouseIcon() As StdPicture
    Set cMouseIcon = UserControl.MouseIcon
End Property
Public Property Set cMouseIcon(ByVal vNewValue As StdPicture)
    Set UserControl.MouseIcon = vNewValue
    PropertyChanged ("cMouseIcon")
End Property
Public Property Get cMousePointer() As Integer
    cMousePointer = UserControl.MousePointer
End Property
Public Property Let cMousePointer(ByVal vNewValue As Integer)
    UserControl.MousePointer = vNewValue
    PropertyChanged ("cMousePointer")
End Property

'背景图片
Public Property Get BkPicture() As Picture
    Set BkPicture = UserControl.Picture

End Property

Public Property Set BkPicture(ByVal vNewValue As StdPicture)
    Set UserControl.Picture = vNewValue
    Draw
    PropertyChanged ("BKPicture")
End Property

'控件面貌()
Public Property Get Appearance() As Integer
    Appearance = UserControl.Appearance
End Property

Public Property Let Appearance(ByVal vNewValue As Integer)
    UserControl.Appearance = vNewValue
    PropertyChanged ("Apperance")
End Property
'边框样式
Public Property Get BorderStyle() As Integer
    BorderStyle = UserControl.BorderStyle
End Property
Public Property Let BorderStyle(ByVal vNewValue As Integer)
    UserControl.BorderStyle = vNewValue
    PropertyChanged ("BorderStyle")
End Property

'控件样式（进度条 或 滑动条）
Public Property Get Style() As sStyle
    Style = cStyle
End Property
Public Property Let Style(ByVal vNewValue As sStyle)
    cStyle = vNewValue
    Draw
    PropertyChanged ("Style")
End Property

' '是否允许在鼠标按下或移动时值改变
Public Property Get CanMove() As Boolean
    CanMove = cCanMove
End Property
Public Property Let CanMove(ByVal vNewValue As Boolean)
    cCanMove = vNewValue
    Draw
    PropertyChanged ("CanMove")
End Property
'---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ----
'渐变色 - 上面
Public Property Get TopColor() As OLE_COLOR
    TopColor = AColor
End Property
Public Property Let TopColor(ByVal vNewValue As OLE_COLOR)
    AColor = vNewValue
    Draw
    PropertyChanged ("TopColor")
End Property
'渐变色 - 下面
Public Property Get BottomColor() As OLE_COLOR
    BottomColor = BColor
End Property
Public Property Let BottomColor(ByVal vNewValue As OLE_COLOR)
    BColor = vNewValue
    Draw
    PropertyChanged ("BottomColor")
End Property
'滑过后的渐变色 - 上面
Public Property Get GotTopColor() As OLE_COLOR
    GotTopColor = gotAColor
End Property
Public Property Let GotTopColor(ByVal vNewValue As OLE_COLOR)
    gotAColor = vNewValue
    Draw
    PropertyChanged ("GotTopColor")
End Property
'滑过后的渐变色 - 下面
Public Property Get GotBottomColor() As OLE_COLOR
    GotBottomColor = BColor
End Property

Public Property Let GotBottomColor(ByVal vNewValue As OLE_COLOR)
    gotBColor = vNewValue
    Draw
    PropertyChanged ("GotBottomColor")
End Property

'---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ---- ---   ----





'最大值
Public Property Let Max(ByVal newValue As Long)
    cMax = newValue
    Draw
    PropertyChanged ("Max")
End Property
Public Property Get Max() As Long
    Max = cMax
End Property

'这两个参数的作用于 显示左右两边菱角，截取少量的空白部分
Public Property Let Bite_LP(ByVal newValue As Integer)
    cBite_LP = newValue * 15
    PropertyChanged ("Bite_LP")
End Property

Public Property Get Bite_LP() As Integer

    Bite_LP = cBite_LP / 15
End Property

Public Property Get Bite_RP() As Integer
    Bite_RP = cBite_RP / 15
End Property

Public Property Let Bite_RP(ByVal newValue As Integer)
    cBite_RP = newValue * 15
    PropertyChanged ("Bite_RP")
End Property

'当前值
Public Property Let Value(ByVal newValue As Long)
    Dim intValue As Long
    Dim CanDraw As Boolean
    If Not IsDown Then
        cValue = newValue
        Draw      '刷新显示
        RaiseEvent Changed(cValue, cMax)
    End If
    PropertyChanged ("Value")
End Property

Public Property Get Value() As Long
    Value = cValue
End Property
'判断是否显示中间的按钮
Public Property Get IsShowCmd() As Boolean
    IsShowCmd = cIsShowCmd
End Property
Public Property Let IsShowCmd(ByVal newValue As Boolean)
    cIsShowCmd = newValue
    Draw
    PropertyChanged ("IsShowCmd")
End Property

'**                                                                                                  **
'**                                                                                                  **
'**                                                                                                  **
'******************************************   属性   **************************************************

'******************************************   程序内部代码  *******************************************
'**                                                                                                  **
'**                                                                                                  **
'**                                                                                                  **

'渐变刷新
Private Sub Dither(ByVal TopColor As Long, ByVal BottomColor As Long, X1 As Single, X2 As Single)
     On Error GoTo Out
    Dim tc As sColor
    Dim bc As sColor
    Dim i As Long
    Dim Sp(3) As Single
    Dim k As Single
    Dim tem_color As Long

    If TopColor = BottomColor Then
        Line (X1, 0)-(X2, Height), TopColor, BF
    Else
        k = 10
        tc = FormatColor(TopColor)
        bc = FormatColor(BottomColor)
        Sp(0) = (tc.Red - bc.Red) / k
        Sp(1) = (tc.Green - bc.Green) / k
        Sp(2) = (tc.Blue - bc.Blue) / k
        Sp(3) = Height / k

        For i = 0 To k
            tem_color = RGB(tc.Red - Sp(0) * i, tc.Green - Sp(1) * i, tc.Blue - Sp(2) * i)
            Line (X1, Sp(3) * i)-(X2, Sp(3) * (i + 1)), tem_color, BF
        Next i
    End If

    Exit Sub
Out:
End Sub