tvate.ctl

非常漂亮的滑动条源代码

Private Sub Timer1_Timer()
    If isMouseOver = False Then
        Timer1.Enabled = False
        IsOver = False
        Draw
    End If
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DBClick
End Sub

Private Sub UserControl_Initialize()
    Max = 100
    Value = 1
    Style = 滑动条_2
    IsShowCmd = True
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    RaiseEvent MouseDown(Button, Shift, X, Y)

    If Button = 1 Then
        IsDown = True

        UserControl_MouseMove Button, Shift, X, Y
    End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim cmd_Width As Integer
    RaiseEvent MouseMove(Button, Shift, X, Y)

    IsOver = True
    Timer1.Enabled = True
    MX = X
    If cCanMove = True Then
        If Button = 1 Then
            
            cmd_Width = IIf(cIsShowCmd, cmP_W, 0)
            cValue = cMax * (X - cmd_Width / 2 - clP_W + cBite_LP) / (ScaleWidth - cmd_Width - clP_W - crP_W + cBite_LP + cBite_RP)
            If cValue > cMax Then cValue = cMax
            If cValue < 0 Then cValue = 0
            RaiseEvent Changed(cValue, cMax)
        End If
        Draw
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
    IsDown = False
    cmdState = M_Up
    Draw
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    With PropBag
        Call .ReadProperty("Style", 2)
        Call .ReadProperty("Value", 1)
        Call .ReadProperty("Max", 1)
        Call .ReadProperty("BKPicture", Nothing)
        Call .ReadProperty("Apperance", 0)
        Call .ReadProperty("BorderStyle", 0)
        Call .ReadProperty("Bite_LP", 0)
        Call .ReadProperty("Bite_RP", 0)
        Call .ReadProperty("IsShowCmd", True)
        
        Call .ReadProperty("TopColor", UserControl.BackColor)
        Call .ReadProperty("BottomColor", UserControl.BackColor)
        Call .ReadProperty("GotTopColor", vbBlue)
        Call .ReadProperty("GotBottomColor", vbBlue)
        
        Call .ReadProperty("CanMove", True)
        
        Call .ReadProperty("Caption", "")
       ' Call .ReadProperty("cMousePointer", 0)
       ' Call .ReadProperty("cMouseIcon", Nothing)
    End With
End Sub

Private Sub UserControl_Resize()
    Draw
End Sub

'获取位图的宽度和高度
Public Function GetPictureWidth(ByVal p As Picture) As Integer
    If p Is Nothing Then
        GetPictureWidth = 0
    Else
        GetPictureWidth = Int(p.Width / MILLICMETERCELL + 0.5)
    End If
End Function
Public Function GetPictureHeight(ByVal p As Picture) As Integer
    If p Is Nothing Then
        GetPictureHeight = 0
    Else
        GetPictureHeight = Int(p.Height / MILLICMETERCELL + 0.5)
    End If
End Function

'判断鼠标是否在控件范围内
Private Function isMouseOver() As Boolean
    Dim pt As PointAPI
    GetCursorPos pt
    isMouseOver = (WindowFromPoint(pt.X, pt.Y) = Hwnd)
End Function

Private Function cmdIsMouseOver() As Boolean
    cmdIsMouseOver = (MX > cmp_X And MX < cmp_X + cmP_W)
End Function

'刷新刷新图片
Private Sub Draw(Optional ByVal X1 As Single = -1)
    On Error Resume Next
    'Dim X1 As Single        '与值对应的X位置

    Dim intValue As Long

    Dim cmd_Width As Integer
    Dim lP_Width  As Integer
    Dim rP_Width  As Integer

    cmd_Width = cmP_W    '滑块的宽度
    lP_Width = clP_W       '左边菱角宽度
    rP_Width = crP_W      '右边菱角宽度

    If cIsShowCmd = False Then cmd_Width = 0

    Cls
    '赋值出错处理
    If cValue <= 0 Then
        intValue = 0
    ElseIf cValue >= cMax Then
        intValue = cMax
    Else
        intValue = cValue
    End If
    
    If cMax < 0 Then cMax = 1

    If X1 = -1 Then X1 = (ScaleWidth - lP_Width - rP_Width - cmd_Width + cBite_LP + cBite_RP) * intValue / cMax + 0.1 + clP_W + cmd_Width / 2 - cBite_LP
    'Debug.Print X1
    'If X1 < lP_Width - cBite_LP Then X1 = lP_Width - cBite_LP
    'If X1 > ScaleWidth - lP_Width + cBite_RP Then X1 = ScaleWidth - lP_Width + cBite_RP

    cmp_X = X1 - cmP_W / 2

    If cStyle = 滑动条_2 Then ''由图片充当渐变色
        PaintPicture cLPicture, 0, 0, lP_Width, ScaleHeight   '左边菱角图片
        PaintPicture cRPicture, ScaleWidth - rP_Width, 0, rP_Width, ScaleHeight   '右边菱角图片
        'TransparencyBlt cLPicture, hdc, 0, 0, LP_Width / 15, ScaleHeight / 15, 0, 0, &HFF00FF
        'TransparencyBlt cRPicture, hdc, 0, 0, RP_Width / 15, ScaleHeight / 15, (ScaleWidth - RP_Width) / 15, 0, &HFF00FF
        PaintPicture cLMPicture, lP_Width, 0, X1 - lP_Width, ScaleHeight   '左边渐变
        PaintPicture cRMPicture, X1, 0, ScaleWidth - X1 - rP_Width, ScaleHeight '右边渐变

    ElseIf cStyle = 两张图片重叠_3 Then '滑动条模式3,两张图片重叠_3

        PaintPicture cLMPicture, 0, 0, X1, ScaleHeight, 0, 0, X1, ScaleHeight
        PaintPicture cRMPicture, X1, 0, ScaleWidth - X1, ScaleHeight, X1, 0, ScaleWidth - X1, ScaleHeight
    Else '进度条模式 或 普通滑动条 模式
        Dither gotAColor, gotBColor, 0, X1       ' 左边渐变
        Dither AColor, BColor, X1, ScaleWidth  '滑块右边渐变
    End If


    If cCaption <> "" Then
        UserControl.CurrentX = (ScaleWidth - UserControl.TextWidth(cCaption)) / 2
        UserControl.CurrentY = (ScaleHeight - UserControl.TextHeight(cCaption)) / 2
        Print cCaption
    End If

    '滑块起作用
    If cIsShowCmd Then
        TransparencyBlt cmdPic, hdc, cmP_W / 15 * GetMouseState, 0, cmP_W / 15, cmP_H, (X1 - cmP_W / 2) / 15, cmP_T, &HFF00FF
    End If

End Sub

'获取中间滑动的按钮的鼠标显示状态
Public Function GetMouseState() As sMouseState
    Dim tMState As sMouseState
    
    If UserControl.Enabled = False Then
        tMState = M_Enabled
    Else
        If CanMove = True Then
        
            If IsDown = True Then
                tMState = M_Down
            Else
                If IsOver = True Then
                    If cmdIsMouseOver Then
                        tMState = M_Over
                    Else
                        tMState = M_Up
                    End If
                Else
                    tMState = M_Up
                End If
            End If
            
            
            If tMState = M_Up Then
                RaiseEvent MouseOutCmd
            Else
                RaiseEvent MouseOverCmd
            End If
        Else
            tMState = M_Up
        End If
    End If
    GetMouseState = tMState
End Function

Public Sub setPicture(ByVal newPicture As StdPicture, Optional ByVal lP_Width As Integer, Optional ByVal rP_Width As Integer, _
                      Optional ByVal lmP_Width As Integer, Optional ByVal rmP_Width As Integer, Optional ByVal cP_Width As Integer _
                      , Optional ByVal cmp_Height As Integer = 0, Optional ByVal cmp_Top As Integer = 0)
    Dim Pic_Height As Integer
    Pic_Height = GetPictureHeight(newPicture)

    If Pic_Height = 0 Then Exit Sub
    If lP_Width = 0 Then
        Set cLPicture = Nothing
    Else
        Set cLPicture = PicToPic(newPicture, 0, 0, lP_Width, Pic_Height)
    End If

    If rP_Width = 0 Then
        Set cRPicture = Nothing
    Else
        Set cRPicture = PicToPic(newPicture, lP_Width, 0, rP_Width, Pic_Height)
    End If
    
    If lmP_Width = 0 Then
        Set cLMPicture = Nothing
    Else
        Set cLMPicture = PicToPic(newPicture, lP_Width + rP_Width, 0, lmP_Width, Pic_Height)
    End If

    If rmP_Width = 0 Then
        Set cRMPicture = Nothing
    Else
        Set cRMPicture = PicToPic(newPicture, lP_Width + rP_Width + lmP_Width, 0, rmP_Width, Pic_Height)
    End If


    If cmp_Height = 0 Then
        cmP_H = Pic_Height
    Else
        cmP_H = cmp_Height
    End If



    If cP_Width = 0 Then
        Set cmdPic = Nothing
    Else
        Set cmdPic = PicToPic(newPicture, lP_Width + rP_Width + lmP_Width + rmP_Width, 0, cP_Width * 4, Pic_Height)
    End If

    'SavePicture cmdPic, "c:\cmdpic.bmp"

    cmP_W = GetPictureWidth(cmdPic) * 15 / 4
    clP_W = GetPictureWidth(cLPicture) * 15
    crP_W = GetPictureWidth(cRPicture) * 15


    cmP_T = cmp_Top
    Draw
End Sub

'Private Sub TPaintPicture()

'BitBlt Me.hdc, 0, 0, picture1.Width, picture1.Height, picture1.hdc, 0, 0, MERGEPAINT
'BitBlt Me.hdc, 0, 0, Picture2.Width, Picture2.Height, Picture2.hdc, 0, 0, SRCAND
'End Sub

'*************************************************************************
'**函 数 名：PicToPic
'**输    入：ByVal thePicture(Picture) -
'**        ：ByVal LeftSrc(Long)       -
'**        ：ByVal TopSrc(Long)        -
'**        ：ByVal WidthSrc(Long)      -
'**        ：ByVal HeightSrc(Long)     -
'**输    出：(Picture) -
'**功能描述：
'**全局变量：
'**调用模块：
'**作    者：雨石
'**日    期：2006-11-03 21:29:14
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Function PicToPic(ByVal thePicture As Picture, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim newHdc As Long
    newHdc = CreateCompatibleDC(hdc)
    SelectObject newHdc, thePicture
    Set PicToPic = hDCToPicture(newHdc, LeftSrc, TopSrc, WidthSrc, HeightSrc)
    DeleteDC newHdc
End Function

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    With PropBag
        Call .WriteProperty("Style", cStyle, 2)
        Call .WriteProperty("Value", cValue, 1)
        Call .WriteProperty("Max", cMax, 100)
        Call .WriteProperty("BKPicture", UserControl.Picture, Nothing)
        Call .WriteProperty("Appearance", UserControl.Appearance, 0)
        Call .WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
        Call .WriteProperty("Bite_LP", cBite_LP, 0)
        Call .WriteProperty("Bite_RP", cBite_RP, 0)
        Call .WriteProperty("IsShowCmd", cIsShowCmd, True)
        
        Call .WriteProperty("TopColor", AColor, UserControl.BackColor)
        Call .WriteProperty("BottomColor", BColor, UserControl.BackColor)
        Call .WriteProperty("GotTopColor", gotAColor, vbBlue)
        Call .WriteProperty("GotBottomColor", gotBColor, vbBlue)
        
        Call .WriteProperty("Caption", cCaption, "")
        
        Call .WriteProperty("CanMove", cCanMove, True)
    End With
End Sub
'*************************************************************************
'**函 数 名：FormatColor
'**输    入：ByVal tem_color(Long) -
'**输    出：(sColor) -
'**功能描述：格式化颜色值
'**全局变量：None
'**调用模块：none
'**作    者：用心
'**日    期：2006-08-11 22:12:44
'**修 改 人：
'**日    期：
'**版    本：V1.1.21
'*************************************************************************
Private Function FormatColor(ByVal tem_color As Long) As sColor
    Dim strTem As String
    Dim temColor As sColor
    strTem = Hex(tem_color)
    strTem = String(6 - Len(strTem), "0") & strTem
    temColor.Red = "&H" & Mid(strTem, 5, 2)
    temColor.Green = "&H" & Mid(strTem, 3, 2)
    temColor.Blue = "&H" & Left(strTem, 2)
    FormatColor = temColor
End Function