cscrollbar.cls

ktv场所的包房开房、迎宾、预定管理系统。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cScrollBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit

' Constants - DrawEdge.Edge
Private Const BDR_RAISEDOUTER As Long = &H1                                  ' Raised outer edge.
Private Const BDR_SUNKENOUTER As Long = &H2                                  ' Sunken outer edge.
Private Const BDR_RAISEDINNER As Long = &H4                                  ' Raised inner edge.
Private Const BDR_SUNKENINNER As Long = &H8                                  ' Sunken inner edge.
Private Const EDGE_RAISED     As Long = (BDR_RAISEDOUTER Or BDR_RAISEDINNER) ' Combination of BDR_RAISEDOUTER and BDR_RAISEDINNER.
Private Const EDGE_SUNKEN     As Long = (BDR_SUNKENOUTER Or BDR_SUNKENINNER) ' Combination of BDR_SUNKENOUTER and BDR_SUNKENINNER.
Private Const EDGE_BUMP       As Long = (BDR_RAISEDOUTER Or BDR_SUNKENINNER) ' Combination of BDR_RAISEDOUTER and BDR_SUNKENINNER.
Private Const EDGE_ETCHED     As Long = (BDR_SUNKENOUTER Or BDR_RAISEDINNER) ' Combination of BDR_SUNKENOUTER and BDR_RAISEDINNER.

' Constants - DrawEdge.Flags
Private Const BF_LEFT                    As Long = &H1                                    ' Left side of border rectangle.
Private Const BF_TOP                     As Long = &H2                                    ' Top of border rectangle.
Private Const BF_RIGHT                   As Long = &H4                                    ' Right side of border rectangle.
Private Const BF_BOTTOM                  As Long = &H8                                    ' Bottom of border rectangle.
Private Const BF_TOPLEFT                 As Long = (BF_TOP Or BF_LEFT)                    ' Top and left side of border rectangle.
Private Const BF_TOPRIGHT                As Long = (BF_TOP Or BF_RIGHT)                   ' Top and right side of border rectangle.
Private Const BF_BOTTOMLEFT              As Long = (BF_BOTTOM Or BF_LEFT)                 ' Bottom and left side of border rectangle.
Private Const BF_BOTTOMRIGHT             As Long = (BF_BOTTOM Or BF_RIGHT)                ' Bottom and right side of border rectangle.
Private Const BF_RECT                    As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM) 'Entire border rectangle.
Private Const BF_DIAGONAL                As Long = &H10                                   ' Diagonal border.
Private Const BF_DIAGONAL_ENDTOPLEFT     As Long = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)     ' Diagonal border. The end point is the top-left corner of the rectangle; the origin is bottom-right corner.
Private Const BF_DIAGONAL_ENDTOPRIGHT    As Long = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)    ' Diagonal border. The end point is the top-right corner of the rectangle; the origin is bottom-left corner.
Private Const BF_DIAGONAL_ENDBOTTOMLEFT  As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)  ' Diagonal border. The end point is the bottom-left corner of the rectangle; the origin is top-right corner.
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT As Long = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT) ' Diagonal border. The end point is the bottom-right corner of the rectangle; the origin is top-left corner.
Private Const BF_MIDDLE                  As Long = &H800                                  ' Interior of rectangle to be filled.
Private Const BF_SOFT                    As Long = &H1000                                 ' Soft buttons instead of tiles.
Private Const BF_ADJUST                  As Long = &H2000                                 ' Rectangle to be adjusted to leave space for client area.
Private Const BF_FLAT                    As Long = &H4000                                 ' Flat border.
Private Const BF_MONO                    As Long = &H8000                                 ' One-dimensional border.

' Constants - Local
Private Const ArrowBitmap_Height As Byte = 7      'PIXELS
Private Const ArrowBitmap_Width  As Byte = 4      'PIXELS
Private Const ScrollButton_Width As Byte = 17     'PIXELS
Private Const AutoScroll_Wait    As Integer = 333 'MILLISECONDS

' Variables - Class Properties
Private blnValueError  As Boolean
Private blnFlat        As Boolean
Private blnScrollHor   As Boolean
Private blnPixelate    As Boolean
Private blnWholeNums   As Boolean
Private intBorderStyle As Integer
Private dblMin         As Double
Private dblMax         As Double
Private dblValue       As Double
Private dblSmallChange As Double
Private dblLargeChange As Double
Private lngBackColor   As Long
Private lngForeColor   As Long
Private lngScrollColor As Long
Private picBackPicture As StdPicture
Private WithEvents objPicBox As PictureBox
Attribute objPicBox.VB_VarHelpID = -1

' Variables - Local
Private rScrollPos       As RECT
Private lngPicHeight     As Long
Private lngPicWidth      As Long
Private lngButtonWidth   As Long
Private lngButtonHeight  As Long
Private dblPreviousValue As Double
Private blnMouseDown     As Boolean
Private blnBtn_Increase  As Boolean
Private blnBtn_Decrease  As Boolean
Private blnBtn_Scroll    As Boolean
Private sngCurX          As Single
Private sngCurY          As Single
Private blnUsePixels     As Boolean

' Win32 Function Declarations
Private Declare Function DrawEdge Lib "USER32.DLL" (ByVal hDC As Long, ByRef pRECT As RECT, ByVal uEdge As Long, ByVal uFlags As Long) As Long 'BOOL
Private Declare Function FillRect Lib "USER32.DLL" (ByVal hDC As Long, ByRef pRECT As RECT, ByVal hBRUSH As Long) As Long 'int
Private Declare Function CreateSolidBrush Lib "GDI32.DLL" (ByVal lngColor As Long) As Long 'HBRUSH
Private Declare Function DeleteObject Lib "GDI32.DLL" (ByVal hObject As Long) As Long 'BOOL
Private Declare Function timeGetTime Lib "WINMM.DLL" () As Long

' Class custom events
Public Event Change()
Public Event Click()
Public Event DblClick()
Public Event GotFocus()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event LostFocus()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
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 OLECompleteDrag(Effect As Long)
Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
Public Event OLESetData(Data As DataObject, DataFormat As Integer)
Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long)
Public Event Resize()



Private Sub Class_Initialize()
  
  ' Set initial class values
  blnValueError = True
  blnFlat = False
  blnScrollHor = True
  blnPixelate = True
  blnWholeNums = True
  intBorderStyle = 0
  dblMin = 0
  dblMax = 1
  dblValue = 0
  
  dblSmallChange = 1
  dblLargeChange = 1
  lngBackColor = TranslateColor(vbButtonFace)
  lngForeColor = TranslateColor(vbButtonText)
  lngScrollColor = TranslateColor(vbWindowBackground)
  
End Sub

Private Sub Class_Terminate()
  
  ' Cleanup used memory
  Set objPicBox = Nothing
  Set picBackPicture = Nothing
  
End Sub

' Sets the background color of the scroll box and scroll buttons
Public Property Get BackColor() As Long
  
  BackColor = lngBackColor
  
End Property
Public Property Let BackColor(ByVal NewValue As Long)
  
  Dim TempColor As Long
  TempColor = TranslateColor(NewValue)
  If TempColor <> -1 Then lngBackColor = TempColor
  DrawScrollbar
  
End Property


' Sets a picture to be drawn in the scroll area below the scroll box
Public Property Get BackgroundPicture() As StdPicture
  
  Set BackgroundPicture = picBackPicture
  
End Property
Public Property Set BackgroundPicture(ByVal NewValue As StdPicture)
  
  Set picBackPicture = NewValue
  
End Property


' If set to 0 (None), no border will be drawn around the scrollbar.
' If set to 1 (Fixed Single), a single line will be drawn around the scrollbar
Public Property Get BorderStyle() As Integer
  
  MousePointer = intBorderStyle
  
End Property
Public Property Let BorderStyle(ByVal NewValue As Integer)
  
  If NewValue = 0 Or NewValue = 1 Then
    intBorderStyle = NewValue
  Else
    Err.Raise 380, "cScrollBar.Value", "Invalid Property Value"
  End If
  
End Property


' If set to FALSE, the scrollbar will be drawn in 3D... like the standard VB scrollbar.
' If set to TRUE, the scrollbar will be drawn with a FLAT style
Public Property Get Flat() As Boolean
  
  Flat = blnFlat
  
End Property
Public Property Let Flat(ByVal NewValue As Boolean)
  
  blnFlat = NewValue
  DrawScrollbar
  
End Property


' Sets the color of the scroll arrows and border
Public Property Get ForeColor() As Long
  
  ForeColor = lngForeColor
  
End Property
Public Property Let ForeColor(ByVal NewValue As Long)
  
  Dim TempColor As Long
  TempColor = TranslateColor(NewValue)
  If TempColor <> -1 Then lngForeColor = TempColor
  DrawScrollbar
  
End Property


' If set to TRUE, the specified PictureBox will be drawn as a horizontal scrollbar (HScroll)
Public Property Get HorizontalScroll() As Boolean
  
  HorizontalScroll = blnScrollHor
  
End Property
Public Property Let HorizontalScroll(ByVal NewValue As Boolean)
  
  blnScrollHor = NewValue
  DrawScrollbar
  
End Property


' Sets how far to move the value if the user clicks between a scroll button and the scroll box
Public Property Get LargeChange() As Double
  
  LargeChange = dblLargeChange
  If blnWholeNums = True Then LargeChange = CDbl(Format(dblLargeChange, "0"))
  
End Property
Public Property Let LargeChange(ByVal NewValue As Double)
  
  dblLargeChange = NewValue
  If blnWholeNums = True Then dblLargeChange = CDbl(Format(dblLargeChange, "0"))
  
End Property


' Sets the maximum value of the scrollbar
Public Property Get Max() As Double
  
  Max = dblMax
  If blnWholeNums = True Then Max = CDbl(Format(dblMax, "0"))
  
End Property
Public Property Let Max(ByVal NewValue As Double)
  
  ' Max can't be less than min
  dblMax = NewValue
  
  ' If the value is greater than the max, change the value
  If blnWholeNums = True Then dblMax = CDbl(Format(dblMax, "0"))
  If dblMax = dblMin Then
    dblValue = dblMax
  ElseIf dblMax > dblMin Then
    If dblValue > dblMax Then
      dblValue = dblMax
    ElseIf dblValue < dblMin Then
      dblValue = dblMin
    End If
  ElseIf dblMax < dblMin Then
    If dblValue > dblMin Then
      dblValue = dblMin
    ElseIf dblValue < dblMax Then
      dblValue = dblMax
    End If
  End If
  
  DrawScrollbar
  
End Property


' Sets the minimum value of the scrollbar
Public Property Get Min() As Double
  
  Min = dblMin
  If blnWholeNums = True Then Min = CDbl(Format(dblMin, "0"))
  
End Property
Public Property Let Min(ByVal NewValue As Double)
  
  ' Min can't be greater than max
  dblMin = NewValue
  
  ' If the value is less than the min, change the value
  If blnWholeNums = True Then dblMin = CDbl(Format(dblMin, "0"))
  If dblMax = dblMin Then
    dblValue = dblMax
  ElseIf dblMax > dblMin Then
    If dblValue > dblMax Then
      dblValue = dblMax
    ElseIf dblValue < dblMin Then
      dblValue = dblMin
    End If
  ElseIf dblMax < dblMin Then
    If dblValue > dblMin Then
      dblValue = dblMin
    ElseIf dblValue < dblMax Then
      dblValue = dblMax
    End If
  End If
  
  DrawScrollbar
  
End Property


' Sets the mouse icon of the scrollbar.  If this is set, you must set the MousePointer property to vbCustom (99)
Public Property Get MouseIcon() As StdPicture
  
  Set MouseIcon = objPicBox.MouseIcon
  
End Property
Public Property Set MouseIcon(ByVal NewValue As StdPicture)
  
  Set objPicBox.MouseIcon = NewValue
  
End Property


' Sets which cursor will show when the user puts the cursor of the scrollbar
Public Property Get MousePointer() As MousePointerConstants
  
  MousePointer = objPicBox.MousePointer
  
End Property
Public Property Let MousePointer(ByVal NewValue As MousePointerConstants)
  
  objPicBox.MousePointer = NewValue
  
End Property


' Specifies which VB PictureBox to turn into a scrollbar
Public Property Get PictureBoxToUse() As Object
  
  Set PictureBoxToUse = objPicBox
  
End Property
Public Property Set PictureBoxToUse(ByVal NewValue As Object)
  
  Dim rRECT As RECT
  
  If NewValue.Appearance <> 0 Then
    Err.Raise -1, "cScrollBar.PictureBoxToUse", "The specified PictureBox control does not have the 'Appearance' property set to '0 - Flat'."
    Exit Property
  End If
  
  Set NewValue.Picture = Nothing
  NewValue.Align = 0 'None
  NewValue.AutoRedraw = True
  NewValue.AutoSize = False
  NewValue.BackColor = lngBackColor
  NewValue.BorderStyle = 0 'None
  NewValue.DrawMode = vbCopyPen
  NewValue.DrawStyle = vbSolid
  NewValue.DrawWidth = 1
  NewValue.FillColor = 0
  NewValue.ScaleMode = vbPixels
  NewValue.Visible = True
  
  blnUsePixels = ContainerScaleModeIsPixels(NewValue.Container)
  
  Set objPicBox = Nothing
  Set objPicBox = NewValue
  objPicBox.Cls
  
  DrawScrollbar
  
End Property


' If set to TRUE, the scroll area will be "pixelated" to look like scrollbars in Win9x
' If set to FALSE, no pixelation will be drawn on the scrollbar... so it will look like WinNT style scrollbars
Public Property Get PixelateScrollArea() As Boolean
  
  PixelateScrollArea = blnPixelate
  
End Property
Public Property Let PixelateScrollArea(ByVal NewValue As Boolean)
  
  blnPixelate = NewValue
  DrawScrollbar
  
End Property
 
' If set to TRUE and the user sets an invalid VALUE (greater than MAX or less than MIN) and error will be raised
Public Property Get RaiseErrorOnInvalidValue() As Boolean
  
  RaiseErrorOnInvalidValue = blnValueError
  
End Property
Public Property Let RaiseErrorOnInvalidValue(ByVal NewValue As Boolean)
  
  blnValueError = NewValue
  
End Property
 
' Sets the color of the scroll area

Public Property Get ScrollColor() As Long
  
  ScrollColor = lngScrollColor
  
End Property
Public Property Let ScrollColor(ByVal NewValue As Long)
  
  Dim TempColor As Long
  TempColor = TranslateColor(NewValue)
  If TempColor <> -1 Then lngScrollColor = TempColor
  DrawScrollbar
  
End Property
 
' Sets how much the value should change when the user clicks on a scroll button
Public Property Get SmallChange() As Double
  
  SmallChange = dblSmallChange
  If blnWholeNums = True Then SmallChange = CDbl(Format(dblSmallChange, "0"))
  
End Property
Public Property Let SmallChange(ByVal NewValue As Double)
  
  dblSmallChange = NewValue
  If blnWholeNums = True Then dblSmallChange = CDbl(Format(dblSmallChange, "0"))