?? cscrollbar.cls
字號:
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
'
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -