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 = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cScrollBar Class Module ' ----------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : January 09, 2002 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : modBitmap.bas (Bitmap module by Kevin Wilson) ' ' Description : This module turns a standard VB PictureBox control into a fully functional ScrollBar. You ' have the ability to turn the PictureBox into a Horizontal or Vertical scrollbar by simply ' setting a class property. This module makes scrollbars that are much better than standard ' VB scrollbars because the Min, Max, Value, SmallChange, and LargeChange properties are ' DOUBLE instead if INTEGER. Because of this, you don't have to put up with a value limit of ' 32,000. It also provides advanced features like color options, flat and 3D looks, and the ' ability to set a picture as the background of the scrollbar. ' ' NOTE : Without alteration, this class module can't be used on PictureBox object arrays because the ' events declared for the PictureBox don't include the "Index As Integer" property. ' ' Example Use : ' ' Public WithEvents HScroll As cScrollBar ' Public WithEvents VScroll As cScrollBar ' Private Sub Form_Load() ' Set HScroll = New cScrollBar ' HScroll.Min = 0 ' HScroll.Max = 1000 ' HScroll.SmallChange = 1 ' HScroll.LargeChange = 5 ' HScroll.HorizontalScroll = True ' Set HScroll.BackgroundPicture = LoadPicture("C:\Pic.bmp") ' Set HScroll.PictureBoxToUse = Picture1 ' Set VScroll = New cScrollBar ' VScroll.Min = 0 ' VScroll.Max = 1000 ' VScroll.SmallChange = 1 ' VScroll.LargeChange = 5 ' VScroll.HorizontalScroll = False ' VScroll.BackColor = &H707070 ' VScroll.ForeColor = &HFF00& ' VScroll.ScrollColor = vbBlack ' VScroll.Flat = True ' VScroll.PixelateScrollArea = True ' VScroll.UseWholeNumbers = False ' Set VScroll.PictureBoxToUse = Picture2 ' End Sub ' Private Sub Form_Unload(Cancel As Integer) ' Set HScroll = Nothing ' Set VScroll = Nothing ' End Sub ' Private Sub HScroll_Change() ' Label1.Caption = HScroll.Value ' End Sub ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyrightİ by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' 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() 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 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 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' 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 PictureBox Set PictureBoxToUse = objPicBox End Property Public Property Set PictureBoxToUse(ByVal NewValue As PictureBox) 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")) 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 End If End Property 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 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 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 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 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ If blnScrollHor = True Then lngBitmapIndent1 = CLng((lngButtonWidth - ArrowBitmap_Width) / 2) lngBitmapIndent2 = CLng((lngButtonHeight - ArrowBitmap_Height) / 2) - 1 ' Create new arrows hDC_ArrowLeft = CreateCompatibleDC(hDC_Screen) hDC_ArrowRight = CreateCompatibleDC(hDC_Screen) CreateArrow vbKeyLeft, hDC_ArrowLeft, hPrevBMP_ArrowLeft CreateArrow vbKeyRight, hDC_ArrowRight, hPrevBMP_ArrowRight ' Draw the LEFT scroll box With rRECT .Top = 0 .Left = 0 .Bottom = lngButtonHeight .Right = lngButtonWidth End With FillRect objPicBox.hDC, rRECT, hBrush_Back BitBlt objPicBox.hDC, lngBitmapIndent1, lngBitmapIndent2 + 1, ArrowBitmap_Width, ArrowBitmap_Height, hDC_ArrowLeft, 0, 0, SRCCOPY If blnMouseDown = True And blnBtn_Scroll = False And sngCurX <= ScrollButton_Width Then DrawEdge objPicBox.hDC, rRECT, lngEdgeDown, BF_RECT Else DrawEdge objPicBox.hDC, rRECT, lngEdgeUp, BF_RECT End If ' Draw the RIGHT scroll box With rRECT .Top = 0 .Left = lngPicWidth - lngButtonWidth .Bottom = lngButtonHeight .Right = lngPicWidth End With FillRect objPicBox.hDC, rRECT, hBrush_Back BitBlt objPicBox.hDC, (lngPicWidth - lngButtonWidth) + (lngBitmapIndent1 + 1), lngBitmapIndent2 + 1, ArrowBitmap_Width, ArrowBitmap_Height, hDC_ArrowRight, 0, 0, SRCCOPY If blnMouseDown = True And blnBtn_Scroll = False And sngCurX >= (lngPicWidth - ScrollButton_Width) Then DrawEdge objPicBox.hDC, rRECT, lngEdgeDown, BF_RECT Else DrawEdge objPicBox.hDC, rRECT, lngEdgeUp, BF_RECT End If ' Draw the scroll button With rScrollPos .Top = 0 If dblValue = dblMin Then .Left = ScrollButton_Width ElseIf dblValue = dblMax Then .Left = lngPicWidth - (ScrollButton_Width * 2) Else dblPercent = (dblValue - dblMin) / (dblMax - dblMin) .Left = ((lngPicWidth - (ScrollButton_Width * 2)) - ScrollButton_Width) * dblPercent .Left = .Left + ScrollButton_Width End If .Bottom = lngPicHeight .Right = .Left + ScrollButton_Width End With FillRect objPicBox.hDC, rScrollPos, hBrush_Back DrawEdge objPicBox.hDC, rScrollPos, lngEdgeUp, BF_RECT '_____________________________________________________________________________________________________________ ' HORIZONTAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Else lngBitmapIndent1 = CLng((lngButtonWidth - ArrowBitmap_Width) / 2) - 1 lngBitmapIndent2 = CLng((lngButtonHeight - ArrowBitmap_Height) / 2) + 1 ' Create new arrows hDC_ArrowUp = CreateCompatibleDC(hDC_Screen) hDC_ArrowDown = CreateCompatibleDC(hDC_Screen) CreateArrow vbKeyUp, hDC_ArrowUp, hPrevBMP_ArrowUp CreateArrow vbKeyDown, hDC_ArrowDown, hPrevBMP_ArrowDown ' Draw the TOP scroll box With rRECT .Top = 0 .Left = 0 .Bottom = lngButtonHeight .Right = lngButtonWidth End With FillRect objPicBox.hDC, rRECT, hBrush_Back BitBlt objPicBox.hDC, lngBitmapIndent1, lngBitmapIndent2, ArrowBitmap_Height, ArrowBitmap_Width, hDC_ArrowUp, 0, 0, SRCCOPY If blnMouseDown = True And blnBtn_Scroll = False And sngCurY <= ScrollButton_Width Then DrawEdge objPicBox.hDC, rRECT, lngEdgeDown, BF_RECT Else DrawEdge objPicBox.hDC, rRECT, lngEdgeUp, BF_RECT End If ' Draw the BOTTOM scroll box With rRECT .Top = lngPicHeight - lngButtonHeight .Left = 0 .Bottom = lngPicHeight .Right = lngPicWidth End With FillRect objPicBox.hDC, rRECT, hBrush_Back BitBlt objPicBox.hDC, lngBitmapIndent1, (lngPicHeight - lngButtonHeight) + (lngBitmapIndent2 + 1), ArrowBitmap_Height, ArrowBitmap_Width, hDC_ArrowDown, 0, 0, SRCCOPY If blnMouseDown = True And blnBtn_Scroll = False And sngCurY >= (lngPicHeight - ScrollButton_Width) Then DrawEdge objPicBox.hDC, rRECT, lngEdgeDown, BF_RECT Else DrawEdge objPicBox.hDC, rRECT, lngEdgeUp, BF_RECT End If ' Draw the scroll button With rScrollPos If dblValue = dblMin Then .Top = ScrollButton_Width ElseIf dblValue = dblMax Then .Top = lngPicHeight - (ScrollButton_Width * 2) Else dblPercent = (dblValue - dblMin) / (dblMax - dblMin) .Top = ((lngPicHeight - (ScrollButton_Width * 2)) - ScrollButton_Width) * dblPercent .Top = .Top + ScrollButton_Width End If .Left = 0 .Bottom = .Top + ScrollButton_Width .Right = lngPicWidth End With FillRect objPicBox.hDC, rScrollPos, hBrush_Back DrawEdge objPicBox.hDC, rScrollPos, lngEdgeUp, BF_RECT End If 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ DrawScrollbar = True CleanUp: objPicBox.Refresh If hDC_Screen <> 0 Then ReleaseDC GetDesktopWindow, hDC_Screen If hDC_ArrowLeft <> 0 Then DeleteObject SelectObject(hDC_ArrowLeft, hPrevBMP_ArrowLeft): DeleteDC hDC_ArrowLeft If hDC_ArrowRight <> 0 Then DeleteObject SelectObject(hDC_ArrowRight, hPrevBMP_ArrowRight): DeleteDC hDC_ArrowRight If hDC_ArrowUp <> 0 Then DeleteObject SelectObject(hDC_ArrowUp, hPrevBMP_ArrowUp): DeleteDC hDC_ArrowUp If hDC_ArrowDown <> 0 Then DeleteObject SelectObject(hDC_ArrowDown, hPrevBMP_ArrowDown): DeleteDC hDC_ArrowDown If hBrush_Back <> 0 Then DeleteObject hBrush_Back If hBrush_Scroll <> 0 Then DeleteObject hBrush_Scroll End Function Private Sub StartMouseDown(ByVal blnIncrease As Boolean, ByVal dblIncrament As Double) Dim lngStartTime_Start As Long Dim lngStartTime_Stop As Long Dim sngLowerEdge As Single Dim sngUpperEdge As Single Dim sngPercent As Single lngStartTime_Start = timeGetTime Do While blnMouseDown = True lngStartTime_Stop = timeGetTime If (lngStartTime_Stop - lngStartTime_Start) >= AutoScroll_Wait Then If blnScrollHor = True Then sngLowerEdge = rScrollPos.Left sngUpperEdge = rScrollPos.Right If blnIncrease = True Then If sngCurX > sngUpperEdge Then GoSub DoIncrament Else If sngCurX < sngLowerEdge Then GoSub DoIncrament End If Else sngLowerEdge = rScrollPos.Top sngUpperEdge = rScrollPos.Bottom If blnIncrease = True Then If sngCurY > sngUpperEdge Then GoSub DoIncrament Else If sngCurY < sngLowerEdge Then GoSub DoIncrament End If End If End If Loop Exit Sub DoIncrament: If blnIncrease = True Then If dblValue >= dblMax Then Return dblValue = dblValue + dblIncrament If dblValue >= dblMax Then dblValue = dblMax Else If dblValue <= dblMin Then Return dblValue = dblValue - dblIncrament If dblValue <= dblMin Then dblValue = dblMin End If DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change Return End Sub 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Private Sub objPicBox_Click() RaiseEvent Click End Sub Private Sub objPicBox_DblClick() RaiseEvent DblClick End Sub Private Sub objPicBox_GotFocus() RaiseEvent GotFocus End Sub Private Sub objPicBox_KeyDown(KeyCode As Integer, Shift As Integer) Dim blnValueUp As Boolean If dblMax = dblMin Then Exit Sub If KeyCode = vbKeyRight Or KeyCode = vbKeyDown Then blnValueUp = False ElseIf KeyCode = vbKeyLeft Or KeyCode = vbKeyUp Then blnValueUp = True End If If dblMax > dblMin Then If blnValueUp = True Then dblValue = dblValue + dblSmallChange If dblValue > dblMax Then dblValue = dblMax Else dblValue = dblValue - dblSmallChange If dblValue < dblMin Then dblValue = dblMin End If Else If blnValueUp = True Then dblValue = dblValue - dblSmallChange If dblValue < dblMax Then dblValue = dblMax Else dblValue = dblValue + dblSmallChange If dblValue > dblMin Then dblValue = dblMin End If End If DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change RaiseEvent KeyDown(KeyCode, Shift) End Sub Private Sub objPicBox_KeyPress(KeyAscii As Integer) RaiseEvent KeyPress(KeyAscii) End Sub Private Sub objPicBox_KeyUp(KeyCode As Integer, Shift As Integer) RaiseEvent KeyUp(KeyCode, Shift) End Sub Private Sub objPicBox_LostFocus() blnMouseDown = False RaiseEvent LostFocus End Sub Private Sub objPicBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngEdgeFlags As Long Dim rRECT As RECT ' Set the default values blnMouseDown = True blnBtn_Decrease = False blnBtn_Increase = False blnBtn_Scroll = False sngCurX = X sngCurY = Y ' Set the edge flag lngEdgeFlags = BDR_SUNKENOUTER If blnFlat = False Then lngEdgeFlags = lngEdgeFlags Or BDR_SUNKENINNER '_____________________________________________________________________________________________________________ ' HORIZONTAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ If blnScrollHor = True Then If sngCurX <= ScrollButton_Width Then blnBtn_Decrease = True If dblValue > dblMin Then dblValue = dblValue - dblSmallChange If dblValue < dblMin Then dblValue = dblMin DrawScrollbar End If With rRECT .Top = 0 .Left = 0 .Bottom = lngPicHeight .Right = ScrollButton_Width End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown False, dblSmallChange ElseIf sngCurX >= lngPicWidth - ScrollButton_Width Then blnBtn_Increase = True If dblValue < dblMax Then dblValue = dblValue + dblSmallChange If dblValue > dblMax Then dblValue = dblMax DrawScrollbar End If With rRECT .Top = 0 .Left = lngPicWidth - ScrollButton_Width .Bottom = lngPicHeight .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown True, dblSmallChange ElseIf sngCurX >= rScrollPos.Left And sngCurX <= rScrollPos.Right Then blnBtn_Scroll = True ElseIf sngCurX < rScrollPos.Left Then dblValue = dblValue - dblLargeChange If dblValue < dblMin Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown False, dblLargeChange ElseIf sngCurX > rScrollPos.Right Then dblValue = dblValue + dblLargeChange If dblValue > dblMax Then dblValue = dblMax DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown True, dblLargeChange End If '_____________________________________________________________________________________________________________ ' VERTICAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Else If sngCurY <= ScrollButton_Width Then blnBtn_Decrease = True If dblValue > dblMin Then dblValue = dblValue - dblSmallChange If dblValue < dblMin Then dblValue = dblMin DrawScrollbar End If With rRECT .Top = 0 .Left = 0 .Bottom = ScrollButton_Width .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown False, dblSmallChange ElseIf sngCurY >= lngPicHeight - ScrollButton_Width Then blnBtn_Increase = True If dblValue < dblMax Then dblValue = dblValue + dblSmallChange If dblValue > dblMax Then dblValue = dblMax DrawScrollbar End If With rRECT .Top = lngPicHeight - ScrollButton_Width .Left = 0 .Bottom = lngPicHeight .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown True, dblSmallChange ElseIf sngCurY >= rScrollPos.Top And sngCurY <= rScrollPos.Bottom Then blnBtn_Scroll = True ElseIf sngCurY < rScrollPos.Top Then dblValue = dblValue - dblLargeChange If dblValue < dblMin Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown False, dblLargeChange ElseIf sngCurY > rScrollPos.Bottom Then dblValue = dblValue + dblLargeChange If dblValue > dblMax Then dblValue = dblMax DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change StartMouseDown True, dblLargeChange End If End If RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub objPicBox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim dblPercent As Double If blnMouseDown = True Then sngCurX = X sngCurY = Y If blnBtn_Scroll = True Then '_____________________________________________________________________________________________________________ ' HORIZONTAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ If blnScrollHor = True Then If sngCurX > ScrollButton_Width And sngCurX < (lngPicWidth - ScrollButton_Width) Then dblPercent = (sngCurX - ScrollButton_Width) / (lngPicWidth - (ScrollButton_Width * 3)) 'If dblMin = dblMax Then ' dblValue = dblMax 'If (dblMin >= 0 And dblMax >= 0) And (dblMax > dblMin) Then dblValue = dblMax * dblPercent 'ElseIf dblMin < 0 And dblMax >= 0 Then 'ElseIf dblMin >= 0 And dblMax < 0 Then 'End If If dblValue > dblMax Then dblValue = dblMax If dblValue < dblMin Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change ElseIf sngCurX < ScrollButton_Width Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change ElseIf sngCurX > (lngPicWidth - ScrollButton_Width) Then dblValue = dblMax DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change End If '_____________________________________________________________________________________________________________ ' VERTICAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Else If sngCurY > ScrollButton_Width And sngCurY < (lngPicHeight - ScrollButton_Width) Then dblPercent = (sngCurY - ScrollButton_Width) / (lngPicHeight - (ScrollButton_Width * 3)) 'If dblMin = dblMax Then ' dblValue = dblMax 'If (dblMin >= 0 And dblMax >= 0) And (dblMax > dblMin) Then dblValue = dblMax * dblPercent 'ElseIf dblMin < 0 And dblMax >= 0 Then 'ElseIf dblMin >= 0 And dblMax < 0 Then 'End If If dblValue > dblMax Then dblValue = dblMax If dblValue < dblMin Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change ElseIf sngCurY < ScrollButton_Width Then dblValue = dblMin DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change ElseIf sngCurY > (lngPicHeight - ScrollButton_Width) Then dblValue = dblMax DrawScrollbar If dblValue <> dblPreviousValue Then dblPreviousValue = dblValue: RaiseEvent Change End If End If End If End If RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub objPicBox_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lngEdgeFlags As Long Dim rRECT As RECT blnMouseDown = False sngCurX = X sngCurY = Y ' Set the edge flag lngEdgeFlags = BDR_RAISEDINNER If blnFlat = False Then lngEdgeFlags = lngEdgeFlags Or BDR_RAISEDOUTER '_____________________________________________________________________________________________________________ ' VERTICAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ If blnScrollHor = True Then If blnBtn_Decrease = True Then With rRECT .Top = 0 .Left = 0 .Bottom = lngPicHeight .Right = ScrollButton_Width End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh ElseIf blnBtn_Increase = True Then With rRECT .Top = 0 .Left = lngPicWidth - ScrollButton_Width .Bottom = lngPicHeight .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh End If '_____________________________________________________________________________________________________________ ' VERTICAL SCROLL BAR 'ŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻŻ Else If blnBtn_Decrease = True Then With rRECT .Top = 0 .Left = 0 .Bottom = ScrollButton_Width .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh ElseIf blnBtn_Increase = True Then With rRECT .Top = lngPicHeight - ScrollButton_Width .Left = 0 .Bottom = lngPicHeight .Right = lngPicWidth End With DrawEdge objPicBox.hDC, rRECT, lngEdgeFlags, BF_RECT objPicBox.Refresh End If End If RaiseEvent MouseUp(Button, Shift, X, Y) End Sub Private Sub objPicBox_OLECompleteDrag(Effect As Long) RaiseEvent OLECompleteDrag(Effect) End Sub Private Sub objPicBox_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent OLEDragDrop(Data, Effect, Button, Shift, X, Y) End Sub Private Sub objPicBox_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) RaiseEvent OLEDragOver(Data, Effect, Button, Shift, X, Y, State) End Sub Private Sub objPicBox_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean) RaiseEvent OLEGiveFeedback(Effect, DefaultCursors) End Sub Private Sub objPicBox_OLESetData(Data As DataObject, DataFormat As Integer) RaiseEvent OLESetData(Data, DataFormat) End Sub Private Sub objPicBox_OLEStartDrag(Data As DataObject, AllowedEffects As Long) RaiseEvent OLEStartDrag(Data, AllowedEffects) End Sub Private Sub objPicBox_Resize() DrawScrollbar RaiseEvent Resize End Sub ' If the container does not have a "ScaleMode" property (like Frame objects), ' the object 's default ScaleMode will be Twips, so return false Private Function ContainerScaleModeIsPixels(ByRef objContainer As Object) As Boolean On Error GoTo ErrorTrap Err.Clear If objContainer.ScaleMode = vbPixels Then ContainerScaleModeIsPixels = True End If ErrorTrap: Err.Clear End Function