niceslider.ctl

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

VERSION 5.00
Begin VB.UserControl NiceSlider 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00E0E0E0&
   CanGetFocus     =   0   'False
   ClientHeight    =   1680
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1260
   ClipControls    =   0   'False
   LockControls    =   -1  'True
   ScaleHeight     =   112
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   84
   ToolboxBitmap   =   "NiceSlider.ctx":0000
   Begin VB.Image iRailPicture 
      Height          =   300
      Left            =   60
      Top             =   315
      Visible         =   0   'False
      Width           =   330
   End
   Begin VB.Image Slider 
      Height          =   300
      Left            =   0
      Picture         =   "NiceSlider.ctx":0312
      Top             =   0
      Visible         =   0   'False
      Width           =   120
   End
End
Attribute VB_Name = "NiceSlider"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

'##  cpvSlider OCX v1.1  ##
'##                      ##
'##  Carles P.V. - 2001  ##
'##  [e-mail]  ##






Option Explicit
'
'## API declarations_
'
Private Declare Function DrawEdge Lib "user32" _
                        (ByVal hdc As Long, _
                         qrc As RECT, _
                         ByVal edge As Long, _
                         ByVal grfFlags As Long) As Long

Private Const BDR_SUNKEN = &HA
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4

Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_BOTTOM = &H8
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Declare Function GetWindowRect Lib "user32" _
                        (ByVal hwnd As Long, _
                         lpRect As RECT) As Long
                         
Private Declare Function SetWindowPos Lib "user32" _
                        (ByVal hwnd As Long, _
                         ByVal hWndInsertAfter As Long, _
                         ByVal x As Long, ByVal y As Long, _
                         ByVal cx As Long, ByVal cy As Long, _
                         ByVal wFlags As Long) As Long
                         
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
                         
Private Type RECT
             Left As Long
             Top As Long
             Right As Long
             Bottom As Long
End Type
'
'## UC Types and Constants:
'
Private Type Point
             x As Single
             y As Single
End Type

Public Enum sOrientationConstants
            [Horizontal]
            [Vertical]
End Enum

Public Enum sRailStyleConstants
            [Sunken]
            [Raised]
            [SunkenSoft]
            [RaisedSoft]
            '[ByPicture] = 99
End Enum
'
'## Private Variables:
'
Private SliderHooked As Boolean '# Slider hooked
Private SliderOffset As Point   '# Slider anchor point

Private R As RECT               '# Rail rectangle
Private AbsCount As Long        '# AbsCount = Max - Min
'
'## Default Property Values:
'
Const m_def_Enabled = True
Const m_def_Orientation = 0     '# Vertical
Const m_def_RailStyle = 3       '# Sunken
Const m_def_ShowValueTip = True '# Show Tip
Const m_def_Min = 0             '# Min = 0
Const m_def_Max = 10            '# Max = 10
Const m_def_Value = 0           '# Value = 0
'
'## Property Variables:
'
Dim m_Enabled As Boolean
Dim m_Orientation As Variant
Dim m_RailStyle As Variant
Dim m_ShowValueTip As Boolean
Dim m_Min As Integer
Dim m_Max As Integer
Dim m_Value As Integer
'
'## Event Declarations:
'
Public Event Change()
Public Event Click()
Public Event ArrivedFirst()
Public Event ArrivedLast()
Public Event MouseDown(Shift As Integer)
Public Event MouseUp(Shift As Integer)
'缺省属性值:
Const m_def_Style = 0
'属性变量:
Dim m_Style As Variant









'##
'## UserControl: InitProperties/ReadProperties/WriteProperties
'##

Private Sub UserControl_InitProperties()

    m_Enabled = m_def_Enabled
    m_Orientation = m_def_Orientation
    m_RailStyle = m_def_RailStyle
    m_ShowValueTip = m_def_ShowValueTip
    m_Min = m_def_Min
    m_Max = m_def_Max
    m_Value = m_def_Value
    
    AbsCount = 10
    ResetSlider
    
    m_Style = m_def_Style
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &HE0E0E0)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    m_Orientation = PropBag.ReadProperty("Orientation", m_def_Orientation)
    m_RailStyle = PropBag.ReadProperty("RailStyle", m_def_RailStyle)
    m_ShowValueTip = PropBag.ReadProperty("ShowValueTip", m_def_ShowValueTip)
    m_Min = PropBag.ReadProperty("Min", m_def_Min)
    m_Max = PropBag.ReadProperty("Max", m_def_Max)
    m_Value = PropBag.ReadProperty("Value", m_def_Value)
    
    Set Slider.Picture = PropBag.ReadProperty("SliderIcon", Nothing)
    Set iRailPicture = PropBag.ReadProperty("RailPicture", Nothing)
    '
    '# Get absolute count and set Slider position
    '
    AbsCount = m_Max - m_Min
    Slider.Left = (m_Value - m_Min) * (ScaleWidth - Slider.Width) / AbsCount
    Slider.Top = (ScaleHeight - Slider.Height) - (m_Value - m_Min) * (ScaleHeight - Slider.Height) / AbsCount
  
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HE0E0E0)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("SliderIcon", Slider.Picture, Nothing)
    Call PropBag.WriteProperty("Orientation", m_Orientation, m_def_Orientation)
    Call PropBag.WriteProperty("RailPicture", iRailPicture, Nothing)
    Call PropBag.WriteProperty("RailStyle", m_RailStyle, m_def_RailStyle)
    Call PropBag.WriteProperty("ShowValueTip", m_ShowValueTip, m_def_ShowValueTip)
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)

    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
End Sub






'##
'## UserControl draw
'##

Private Sub UserControl_Show()
    '
    '## Draw control
    '
    Refresh
    
End Sub

Private Sub UserControl_Resize()

    On Error Resume Next
    '
    '## Resize control
    '
    If m_RailStyle = 99 And iRailPicture <> 0 Then
    
        Select Case m_Orientation
            
            Case 0 '# Horizontal
                    If Slider.Height < iRailPicture.Height Then
                       Size iRailPicture.Width * 15 + 60, iRailPicture.Height * 15
                    Else
                       Size iRailPicture.Width * 15 + 60, Slider.Height * 15
                    End If
            
            Case 1 '# Vertical
                    If Slider.Width < iRailPicture.Width Then
                       Size iRailPicture.Width * 15, iRailPicture.Height * 15 + 60
                    Else
                       Size Slider.Width * 15, iRailPicture.Height * 15 + 60
                    End If
            
        End Select
    
    Else
    
        Select Case m_Orientation
            
            Case 0 '# Horizontal
                    If Width = 0 Then Width = Slider.Width * 15
                    Height = Slider.Height * 15
                    
            Case 1 '# Vertical
                    If Height = 0 Then Height = Slider.Height * 15
                    Width = (Slider.Width) * 15
            
        End Select
    
    End If
    '
    '## Update slider position
    '
    Select Case m_Orientation
    
        Case 0 '# Horizontal
                If Slider.Height < iRailPicture.Height And _
                   m_RailStyle = 99 And _
                   iRailPicture <> 0 Then
                   Slider.Top = (iRailPicture.Height - Slider.Height) * 0.5
                Else
                   Slider.Top = 0
                End If
                Slider.Left = (m_Value - m_Min) * (ScaleWidth - Slider.Width) / AbsCount
        
        Case 1 '# Vertical
                If Slider.Width < iRailPicture.Width And _
                   m_RailStyle = 99 And _
                   iRailPicture <> 0 Then
                   Slider.Left = (iRailPicture.Width - Slider.Width) * 0.5
                Else
                   Slider.Left = 0
                End If
                Slider.Top = ScaleHeight - Slider.Height - (m_Value - m_Min) * (ScaleHeight - Slider.Height) / AbsCount
   
    End Select
    '
    '## Define rail rectangle
    '
    Select Case m_Orientation
        
        Case 0 '# Horizontal
                R.Top = (Slider.Height - 4) * 0.5
                R.Bottom = R.Top + 4
                R.Left = Slider.Width * 0.5 - 2
                R.Right = R.Left + ScaleWidth - Slider.Width + 4
        
        Case 1 '# Vertical
                R.Top = Slider.Height * 0.5 - 2
                R.Bottom = R.Top + ScaleHeight - Slider.Height + 4
                R.Left = (Slider.Width - 4) * 0.5
                R.Right = R.Left + 4
    
    End Select
    '
    '# Refresh control
    '
    Refresh
    
    On Error GoTo 0
    
End Sub

Private Sub Refresh()
    '
    '## Clear control
    '
    Cls
    '
    '## Draw rail...
    '
    On Error Resume Next
    
    If m_RailStyle = 99 Then
    
        Select Case m_Orientation
        
            Case 0 '# Horizontal
                    PaintPicture iRailPicture, 2, (ScaleHeight - iRailPicture.Height) * 0.5
                 
            Case 1 '# Vertical
                    PaintPicture iRailPicture, (ScaleWidth - iRailPicture.Width) * 0.5, 2
                 
        End Select

    Else
    
       DrawEdge hdc, R, Choose(m_RailStyle + 1, &HA, &H5, &H2, &H4, 0), BF_RECT
    
    End If
    '
    '画条
            PaintPicture Slider, Slider.Left, Slider.Top
  ' End Select
    '
    '## Show value tip
    '
    If m_ShowValueTip And SliderHooked Then ShowTip
    
    On Error GoTo 0

End Sub






'##
'## Scrolling...
'##

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    If Not Me.Enabled Then Exit Sub