cscrollbar.cls

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

End Property


' Sets the tab index of the PictureBox
Public Property Get TabIndex() As Integer
  
  TabIndex = objPicBox.TabIndex
  
End Property
Public Property Let TabIndex(ByVal NewValue As Integer)
  
  objPicBox.TabIndex = NewValue
  
End Property


' Sets whether the scrollbar should be inserted to the form's tab order or not
Public Property Get TabStop() As Boolean
  
  TabStop = objPicBox.TabStop
  
End Property
Public Property Let TabStop(ByVal NewValue As Boolean)
  
  objPicBox.TabStop = NewValue
  
End Property


' If set to TRUE the MIN, MAX, VALUE, SMALLCHANGE, and LARGECHANGE properties will all be
' converted to whole numbers (no decimals).  Decimal numbers 5 and above are rounded up.
Public Property Get UseWholeNumbers() As Boolean
  
  UseWholeNumbers = blnWholeNums
  
End Property
Public Property Let UseWholeNumbers(ByVal NewValue As Boolean)
  
  blnWholeNums = NewValue
  
End Property


' The current value of the scrollbar
Public Property Get Value() As Double
  
  Value = dblValue
  If blnWholeNums = True Then Value = CDbl(Format(dblValue, "0"))
  
End Property
Public Property Let Value(ByVal NewValue As Double)
  
  ' Invalid value specified
  If (NewValue > dblMax Or NewValue < dblMin) And (dblMax > dblMin) And blnValueError = True Then
    Err.Raise 380, "cScrollBar.Value", "Invalid Property Value"
    
  ' Invalid value specified
  ElseIf (NewValue < dblMax Or NewValue > dblMin) And (dblMax < dblMin) And blnValueError = True Then
    Err.Raise 380, "cScrollBar.Value", "Invalid Property Value"
    
  ' Value specified is good... display it it
  Else
    
    dblValue = NewValue
    If blnWholeNums = True Then dblValue = CDbl(Format(dblValue, "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
    RaiseEvent Change
  End If
  
End Property


Public Sub Move(ByVal sngLeft As Single, Optional ByVal sngTop As Single, Optional ByVal sngWidth As Single, Optional ByVal sngHeight As Single)
  
  If objPicBox Is Nothing Then Exit Sub
  objPicBox.Move sngLeft, sngTop, sngWidth, sngHeight
  
End Sub

Public Sub OLEDrag()
  
  If objPicBox Is Nothing Then Exit Sub
  objPicBox.OLEDrag
  
End Sub

Public Sub Refresh()
  
  If objPicBox Is Nothing Then Exit Sub
  DrawScrollbar
  
End Sub

Public Sub SetFocus()
  
  objPicBox.SetFocus
  
End Sub

Public Sub ZOrder(Optional ByVal Position As ZOrderConstants = vbBringToFront)
  
  If objPicBox Is Nothing Then Exit Sub
  objPicBox.ZOrder Position
  
End Sub


Private Function CreateArrow(ByVal bytArrowDirection As Byte, _
                             ByRef hDC_Arrow As Long, _
                             ByRef Return_hPrevBMP As Long) As Boolean
  
  Dim rRECT      As RECT
  Dim hDC_Screen As Long ' << Handle to Desktop DC
  Dim hBMP_Temp  As Long ' << Win32 BITMAP GDI Object (Don't delete because it gets passed back in the hDC_Arrow parameter
  Dim hBRUSH     As Long ' << Win32 BRUSH GDI Object
  Dim lngX       As Long
  Dim lngY       As Long
  
  ' Clear variables
  Return_hPrevBMP = 0
  
  ' Validate parameters
  If objPicBox Is Nothing Then Exit Function
  If hDC_Arrow = 0 Then Exit Function
  If bytArrowDirection <> vbKeyUp And _
     bytArrowDirection <> vbKeyDown And _
     bytArrowDirection <> vbKeyLeft And _
     bytArrowDirection <> vbKeyRight Then Exit Function
  
  ' Create brush to draw with
  hBRUSH = CreateSolidBrush(lngBackColor)
  If hBRUSH = 0 Then Exit Function
  
  ' Get a handle to the desktop DC
  hDC_Screen = GetDC(GetDesktopWindow)
  
  ' Create the bitmap to draw with
  If bytArrowDirection = vbKeyLeft Or bytArrowDirection = vbKeyRight Then
    With rRECT
      .Top = 0
      .Left = 0
      .Bottom = ArrowBitmap_Height
      .Right = ArrowBitmap_Width
    End With
    hBMP_Temp = CreateCompatibleBitmap(hDC_Screen, ArrowBitmap_Width, ArrowBitmap_Height)
  Else
    With rRECT
      .Top = 0
      .Left = 0
      .Bottom = ArrowBitmap_Width
      .Right = ArrowBitmap_Height
    End With
    hBMP_Temp = CreateCompatibleBitmap(hDC_Screen, ArrowBitmap_Height, ArrowBitmap_Width)
  End If
  If hBMP_Temp = 0 Then GoTo CleanUp
  
  ' Put the bitmap into the DC
  Return_hPrevBMP = SelectObject(hDC_Arrow, hBMP_Temp)
  
  ' Draw the background on it
  FillRect hDC_Arrow, rRECT, hBRUSH
  
  ' UP ARROW
  If bytArrowDirection = vbKeyUp Then
    lngY = 0: lngX = 3: GoSub DrawPixel
    
    lngY = 1: lngX = 2: GoSub DrawPixel
    lngY = 1: lngX = 3: GoSub DrawPixel
    lngY = 1: lngX = 4: GoSub DrawPixel
    
    lngY = 2: lngX = 1: GoSub DrawPixel
    lngY = 2: lngX = 2: GoSub DrawPixel
    lngY = 2: lngX = 3: GoSub DrawPixel
    lngY = 2: lngX = 4: GoSub DrawPixel
    lngY = 2: lngX = 5: GoSub DrawPixel
    
    lngY = 3: lngX = 0: GoSub DrawPixel
    lngY = 3: lngX = 1: GoSub DrawPixel
    lngY = 3: lngX = 2: GoSub DrawPixel
    lngY = 3: lngX = 3: GoSub DrawPixel
    lngY = 3: lngX = 4: GoSub DrawPixel
    lngY = 3: lngX = 5: GoSub DrawPixel
    lngY = 3: lngX = 6: GoSub DrawPixel
    lngY = 3: lngX = 7: GoSub DrawPixel
    
  ' DOWN ARROW
  ElseIf bytArrowDirection = vbKeyDown Then
    lngY = 3: lngX = 3: GoSub DrawPixel
    
    lngY = 2: lngX = 2: GoSub DrawPixel
    lngY = 2: lngX = 3: GoSub DrawPixel
    lngY = 2: lngX = 4: GoSub DrawPixel
    
    lngY = 1: lngX = 1: GoSub DrawPixel
    lngY = 1: lngX = 2: GoSub DrawPixel
    lngY = 1: lngX = 3: GoSub DrawPixel
    lngY = 1: lngX = 4: GoSub DrawPixel
    lngY = 1: lngX = 5: GoSub DrawPixel
    
    lngY = 0: lngX = 0: GoSub DrawPixel
    lngY = 0: lngX = 1: GoSub DrawPixel
    lngY = 0: lngX = 2: GoSub DrawPixel
    lngY = 0: lngX = 3: GoSub DrawPixel
    lngY = 0: lngX = 4: GoSub DrawPixel
    lngY = 0: lngX = 5: GoSub DrawPixel
    lngY = 0: lngX = 6: GoSub DrawPixel
    lngY = 0: lngX = 7: GoSub DrawPixel
    
  ' LEFT ARROW
  ElseIf bytArrowDirection = vbKeyLeft Then
    lngX = 0: lngY = 3: GoSub DrawPixel
    
    lngX = 1: lngY = 2: GoSub DrawPixel
    lngX = 1: lngY = 3: GoSub DrawPixel
    lngX = 1: lngY = 4: GoSub DrawPixel
    
    lngX = 2: lngY = 1: GoSub DrawPixel
    lngX = 2: lngY = 2: GoSub DrawPixel
    lngX = 2: lngY = 3: GoSub DrawPixel
    lngX = 2: lngY = 4: GoSub DrawPixel
    lngX = 2: lngY = 5: GoSub DrawPixel
    
    lngX = 3: lngY = 0: GoSub DrawPixel
    lngX = 3: lngY = 1: GoSub DrawPixel
    lngX = 3: lngY = 2: GoSub DrawPixel
    lngX = 3: lngY = 3: GoSub DrawPixel
    lngX = 3: lngY = 4: GoSub DrawPixel
    lngX = 3: lngY = 5: GoSub DrawPixel
    lngX = 3: lngY = 6: GoSub DrawPixel
    lngX = 3: lngY = 7: GoSub DrawPixel
    
  ' RIGHT ARROW
  ElseIf bytArrowDirection = vbKeyRight Then
    lngX = 3: lngY = 3: GoSub DrawPixel
    
    lngX = 2: lngY = 2: GoSub DrawPixel
    lngX = 2: lngY = 3: GoSub DrawPixel
    lngX = 2: lngY = 4: GoSub DrawPixel
    
    lngX = 1: lngY = 1: GoSub DrawPixel
    lngX = 1: lngY = 2: GoSub DrawPixel
    lngX = 1: lngY = 3: GoSub DrawPixel
    lngX = 1: lngY = 4: GoSub DrawPixel
    lngX = 1: lngY = 5: GoSub DrawPixel
    
    lngX = 0: lngY = 0: GoSub DrawPixel
    lngX = 0: lngY = 1: GoSub DrawPixel
    lngX = 0: lngY = 2: GoSub DrawPixel
    lngX = 0: lngY = 3: GoSub DrawPixel
    lngX = 0: lngY = 4: GoSub DrawPixel
    lngX = 0: lngY = 5: GoSub DrawPixel
    lngX = 0: lngY = 6: GoSub DrawPixel
    lngX = 0: lngY = 7: GoSub DrawPixel
    
  End If
  
  CreateArrow = True
  
CleanUp:
  
  If hDC_Screen <> 0 Then ReleaseDC GetDesktopWindow, hDC_Screen
  If hBRUSH <> 0 Then DeleteObject hBRUSH
  Exit Function
  
DrawPixel:
  
  SetPixel hDC_Arrow, lngX, lngY, lngForeColor
  Return
  
End Function

Private Function DrawPixelation() As Boolean
  
  Dim rRECT       As RECT
  Dim hDC_Screen  As Long ' << Handle to Desktop DC
  Dim hDC_Temp    As Long ' << Win32 Memory DC GDI Object
  Dim hBMP_Temp   As Long ' << Win32 BITMAP GDI Object
  Dim hBMP_Prev   As Long ' << Win32 BITMAP GDI Object
  Dim hBRUSH      As Long ' << Win32 BRUSH GDI Object
  Dim lngTheWidth As Long
  Dim lngX        As Long
  Dim lngY        As Long
  Dim blnSkip     As Boolean
  Dim blnStartON  As Boolean
  
  If objPicBox Is Nothing Then Exit Function
  
  ' Get a handle to desktop to create compatible DC and BITMAP objects with
  hDC_Screen = GetDC(GetDesktopWindow)
  If hDC_Screen = 0 Then Exit Function
  
  ' Create the brush to use
  hBRUSH = CreateSolidBrush(lngScrollColor)
  If hBRUSH = 0 Then GoTo CleanUp
  
  ' Create a Device Context (DC) to hold the picture
  hDC_Temp = CreateCompatibleDC(hDC_Screen)
  If hDC_Temp = 0 Then GoTo CleanUp
  
  ' Create bitmap to resize the DC with
  hBMP_Temp = CreateCompatibleBitmap(hDC_Screen, 10, 10)
  If hBMP_Temp = 0 Then GoTo CleanUp
  
  ' Put the bitmap into the DC to resize it
  hBMP_Prev = SelectObject(hDC_Temp, hBMP_Temp)
  
  ' Paint the background onto it
  rRECT.Right = 10
  rRECT.Bottom = 10
  FillRect hDC_Temp, rRECT, hBRUSH
  
  ' Loop through and pixelate the bitmap
  For lngX = 0 To 9
    blnStartON = Not blnStartON
    blnSkip = blnStartON
    For lngY = 0 To 9
      blnSkip = Not blnSkip
      If blnSkip = False Then SetPixel hDC_Temp, lngX, lngY, lngBackColor
    Next lngY
  Next lngX
  
  ' Get the BITMAP out of the DC
  hBMP_Temp = SelectObject(hDC_Temp, hBMP_Prev)
  
  ' Tile the bitmap onto the DC
  TileBitmap objPicBox.hDC, hBMP_Temp, lngPicWidth, lngPicHeight
  
  DrawPixelation = True
  
CleanUp:
  
  If hDC_Screen <> 0 Then ReleaseDC GetDesktopWindow, hDC_Screen
  If hDC_Temp <> 0 Then DeleteDC hDC_Temp
  If hBMP_Temp <> 0 Then DeleteObject hBMP_Temp
  If hBRUSH <> 0 Then DeleteObject hBRUSH
  
End Function

Private Function DrawScrollbar() As Boolean
  
  Dim rRECT               As RECT
  Dim hBrush_Back         As Long ' << Win32 BRUSH GDI Object
  Dim hBrush_Scroll       As Long ' << Win32 BRUSH GDI Object
  Dim hDC_Screen          As Long ' << Handle to the Desktop DC
  Dim hDC_ArrowLeft       As Long ' << Win32 Memory DC GDI Object
  Dim hDC_ArrowRight      As Long ' << Win32 Memory DC GDI Object
  Dim hDC_ArrowUp         As Long ' << Win32 Memory DC GDI Object
  Dim hDC_ArrowDown       As Long ' << Win32 Memory DC GDI Object
  Dim hPrevBMP_ArrowLeft  As Long ' << Win32 BITMAP GDI Object
  Dim hPrevBMP_ArrowRight As Long ' << Win32 BITMAP GDI Object
  Dim hPrevBMP_ArrowUp    As Long ' << Win32 BITMAP GDI Object
  Dim hPrevBMP_ArrowDown  As Long ' << Win32 BITMAP GDI Object
  Dim lngEdgeDown         As Long
  Dim lngEdgeUp           As Long
  Dim lngBitmapIndent1    As Long
  Dim lngBitmapIndent2    As Long
  Dim dblPercent          As Double
  
  If objPicBox Is Nothing Then Exit Function
  
  ' Set the edge flag
  lngEdgeUp = BDR_RAISEDINNER
  If blnFlat = False Then lngEdgeUp = lngEdgeUp Or BDR_RAISEDOUTER
  lngEdgeDown = BDR_SUNKENOUTER
  If blnFlat = False Then lngEdgeDown = lngEdgeDown Or BDR_SUNKENINNER
  
  ' Get the size of the PictureBox
  If blnUsePixels = True Then
    lngPicHeight = objPicBox.height
    lngPicWidth = objPicBox.width
  Else
    lngPicWidth = objPicBox.width / Screen.TwipsPerPixelX
    lngPicHeight = objPicBox.height / Screen.TwipsPerPixelY
  End If
  
  ' Get the size of the scroll boxes
  If blnScrollHor = True Then
    lngButtonHeight = lngPicHeight
    lngButtonWidth = ScrollButton_Width
  Else
    lngButtonHeight = ScrollButton_Width
    lngButtonWidth = lngPicWidth
  End If
  
  ' Get a handle to the Desktop DC.  This is ued to create compatible DC's and BITMAP's
  hDC_Screen = GetDC(GetDesktopWindow)
  If hDC_Screen = 0 Then Exit Function
  
  ' Create brush to draw with
  hBrush_Back = CreateSolidBrush(lngBackColor)
  If hBrush_Back = 0 Then GoTo CleanUp
  hBrush_Scroll = CreateSolidBrush(lngScrollColor)
  If hBrush_Scroll = 0 Then GoTo CleanUp
  
  ' Draw picture onto background
  If Not picBackPicture Is Nothing Then
    TileBitmap objPicBox.hDC, picBackPicture.Handle, lngPicWidth, lngPicHeight
    
  ' Draw pixelation onto background
  ElseIf blnPixelate = True Then
    DrawPixelation
    
  ' Fill in the background with a solid color
  Else
    With rRECT
      .Top = 0
      .Left = 0
      .Bottom = lngPicHeight
      .Right = lngPicWidth
    End With
    FillRect objPicBox.hDC, rRECT, hBrush_Scroll
  End If
  
  ' Draw edge around the scroll area
  If intBorderStyle = 1 Then
    objPicBox.Line (0, 0)-(0, lngPicHeight), lngForeColor                              'LEFT
    objPicBox.Line (lngPicWidth - 1, 0)-(lngPicWidth - 1, lngPicHeight), lngForeColor  'RIGHT
    objPicBox.Line (0, 0)-(lngPicWidth, 0), lngForeColor                               'TOP
    objPicBox.Line (0, lngPicHeight - 1)-(lngPicWidth, lngPicHeight - 1), lngForeColor 'BOTTOM
  End If
  
'_____________________________________________________________________________________________________________
' HORIZONTAL SCROLL BAR
'