niceslider.ctl

来自「非常漂亮的VB控件」· CTL 代码 · 共 771 行 · 第 1/2 页

    With Slider
        '
        '# Hook slider, get offsets and show tip
        '
        If Button = vbLeftButton Then
           
            SliderHooked = True
            '
            '# If mouse over slider
            '
            If x >= .Left And x < .Left + .Width And _
               y >= .Top And y < .Top + .Height Then
               
                SliderOffset.x = x - .Left
                SliderOffset.y = y - .Top
            '
            '# If mouse over rail
            '
            Else
                SliderOffset.x = .Width / 2
                SliderOffset.y = .Height / 2
                UserControl_MouseMove Button, Shift, x, y
                
            End If
            '
            '# Show tip
            '
            If m_ShowValueTip Then
                 ShowTip
            End If
            
            RaiseEvent MouseDown(Shift)
           
        End If

    End With
 
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    If SliderHooked Then
        '
        '## Check limits
        '
        With Slider
        Select Case m_Orientation
            
            Case 0 '# Horizontal
                    If x - SliderOffset.x < 0 Then
                        .Left = 0
                    ElseIf x - SliderOffset.x > ScaleWidth - .Width Then
                        .Left = ScaleWidth - .Width
                    Else
                        .Left = x - SliderOffset.x
                    End If
            
            Case 1 '# Vertical
                    If y - SliderOffset.y < 0 Then
                        .Top = 0
                    ElseIf y - SliderOffset.y > ScaleHeight - .Height Then
                        .Top = ScaleHeight - .Height
                    Else
                        .Top = y - SliderOffset.y
                    End If
        
        End Select
        End With
        '
        '## Get value from Slider position
        '
        Value = GetValue
    
    End If

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    '
    '# Click event (If mouse over control area)
    '
    If x >= 0 And x < ScaleWidth And _
       y >= 0 And y < ScaleHeight And _
       Button = vbLeftButton Then

       RaiseEvent Click
       
    End If
    '
    '# MouseUp event (If slider has been hooked)
    '
    If SliderHooked Then RaiseEvent MouseUp(Shift)
    '
    '## Unhook slider and hide value tip
    '
    SliderHooked = False
    Unload frmValueTip
    
End Sub






'##
'## Properties
'##

'## Enabled
    Public Property Get Enabled() As Boolean
        Enabled = m_Enabled
    End Property
    
    Public Property Let Enabled(ByVal New_Enabled As Boolean)
        m_Enabled = New_Enabled
        PropertyChanged "Enabled"
    End Property
'
''## BackColor
'    Public Property Get BackColor() As OLE_COLOR
'        BackColor = UserControl.BackColor
'    End Property
'
'    Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
'        UserControl.BackColor() = New_BackColor
'        Refresh
'        PropertyChanged "BackColor"
'    End Property
    
'## Max
    Public Property Get Max() As Long
        Max = m_Max
    End Property
    
    Public Property Let Max(ByVal New_Max As Long)
    
        If New_Max <= m_Min Then err.Raise 380
        
        m_Max = New_Max
        AbsCount = m_Max - m_Min
        PropertyChanged "Max"
        
    End Property

'## Min
    Public Property Get Min() As Long
        Min = m_Min
    End Property
    
    Public Property Let Min(ByVal New_Min As Long)
    
        If New_Min >= m_Max Then err.Raise 380
        
        m_Min = New_Min
        Value = New_Min
        AbsCount = m_Max - m_Min
        PropertyChanged "Min"
        
    End Property

'## Value
    Public Property Get Value() As Long
Attribute Value.VB_UserMemId = 0
        Value = m_Value
    End Property
    
    Public Property Let Value(ByVal New_Value As Long)
    
        Static LastValue As Long
        
        If New_Value < m_Min Or New_Value > m_Max Then err.Raise 380
        m_Value = New_Value
            
            If m_Value <> LastValue Then
                
                If Not SliderHooked Then
                           
                    Select Case m_Orientation
        
                        Case 0 '# Horizontal
                                Slider.Left = (New_Value - m_Min) * (ScaleWidth - Slider.Width) / AbsCount
                        
                        Case 1 '# Vertical
                                Slider.Top = ScaleHeight - Slider.Height - (New_Value - m_Min) * (ScaleHeight - Slider.Height) / AbsCount
       
                    End Select
    
                End If
                
                Refresh
                LastValue = m_Value
                
                RaiseEvent Change
                If m_Value = m_Max Then RaiseEvent ArrivedLast
                If m_Value = m_Min Then RaiseEvent ArrivedFirst
        
            End If
            
        PropertyChanged "Value"
        
    End Property

'## Orientation
    Public Property Get Orientation() As sOrientationConstants
        Orientation = m_Orientation
    End Property
    
    Public Property Let Orientation(ByVal New_Orientation As sOrientationConstants)
        
        m_Orientation = New_Orientation
        If m_Orientation = 1 Then
            Slider.Picture = LoadResPicture(5000 + m_Style, 0)
        Else
            Slider.Picture = LoadResPicture(5100 + m_Style, 0)
        End If
        ResetSlider
        UserControl_Resize
        
        PropertyChanged "Orientation"
        
    End Property
    
'## RailStyle
    Public Property Get RailStyle() As sRailStyleConstants
        RailStyle = m_RailStyle
    End Property
    
    Public Property Let RailStyle(ByVal New_RailStyle As sRailStyleConstants)
    
        m_RailStyle = New_RailStyle
       
        UserControl_Resize
        
        PropertyChanged "RailStyle"
        
    End Property
'
''## SliderIcon
'    Public Property Get SliderIcon() As Picture
'        Set SliderIcon = Slider.Picture
'    End Property
'
'    Public Property Set SliderIcon(ByVal New_SliderIcon As Picture)
'
'        Set Slider.Picture = New_SliderIcon
'
'        UserControl_Resize
'
'        PropertyChanged "SliderIcon"
'
'    End Property
''
'''## RailPicture
''    Public Property Get RailPicture() As Picture
''        Set RailPicture = iRailPicture.Picture
''    End Property
''
''    Public Property Set RailPicture(ByVal New_RailPicture As Picture)
''
''        Set iRailPicture.Picture = New_RailPicture
''
''        UserControl_Resize
''
''        PropertyChanged "RailPicture"
''
''    End Property
    
'## ShowValueTip
    Public Property Get ShowValueTip() As Boolean
        ShowValueTip = m_ShowValueTip
    End Property
    
    Public Property Let ShowValueTip(ByVal New_ShowValueTip As Boolean)
        m_ShowValueTip = New_ShowValueTip
        PropertyChanged "ShowValueTip"
    End Property






'##
'## Private Functions/Subs
'##

'#
'# Get value from Slider position
'#
Private Function GetValue() As Integer
    
    On Error Resume Next
    Select Case m_Orientation
    
        Case 0 '# Horizontal
                GetValue = Slider.Left / (ScaleWidth - Slider.Width) * AbsCount + m_Min
                Slider.Left = (GetValue - m_Min) * (ScaleWidth - Slider.Width) / AbsCount
        
        Case 1 '# Vertical
                GetValue = (ScaleHeight - Slider.Height - Slider.Top) / (ScaleHeight - Slider.Height) * AbsCount + m_Min
                Slider.Top = ScaleHeight - Slider.Height - (GetValue - m_Min) * (ScaleHeight - Slider.Height) / AbsCount
   
    End Select
    On Error GoTo 0
    
End Function
'#
'# Reset slider position
'#
Private Sub ResetSlider()

    Select Case m_Orientation
        
        Case 0 '# Horizontal
                Slider.Move 0, 0
             
        Case 1 '# Vertical
                Slider.Move 0, ScaleHeight - Slider.Height
             
    End Select
    
End Sub
'#
'# Show value tip
'#
Private Sub ShowTip()
    
    Dim ucR As RECT
    Dim x As Long, y As Long

    On Error Resume Next
    
    GetWindowRect hwnd, ucR
    
    With frmValueTip
    
        .lblTip.Width = .TextWidth(m_Value)
        .lblTip.Caption = m_Value
        .lblTip.Refresh
        
        Select Case m_Orientation
            
            Case 0 '# Horizontal
                    x = ucR.Left + Slider.Left + (Slider.Width - .lblTip.Width - 4) * 0.5
                    y = ucR.Top + Slider.Top - .lblTip.Height - 5
                 
            Case 1 '# Vertical
                    x = ucR.Left + Slider.Left - .lblTip.Width - 6
                    y = ucR.Top + Slider.Top + (Slider.Height - .lblTip.Height - 4) * 0.5
                 
        End Select
        '
        '# Set Tip position...
        '
        .Move x * 15, y * 15, (.lblTip.Width + 4) * 15, (.lblTip.Height + 3) * 15
        '
        '# ...and show it
        '
        SetWindowPos .hwnd, HWND_TOP, 0, 0, 0, 0, _
                            SWP_NOACTIVATE Or SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
    
    End With
    
    On Error GoTo 0

End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,0
Public Property Get Style() As MnuStyle
    Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As MnuStyle)
    m_Style = New_Style
    If m_Orientation = 1 Then
        Slider.Picture = LoadResPicture(5000 + m_Style, 0)
    Else
        Slider.Picture = LoadResPicture(5100 + m_Style, 0)
    End If
    UserControl_Resize
    PropertyChanged "Style"
End Property