VERSION 5.00
Begin VB.UserControl cScrollBar 
   AutoRedraw      =   -1  'True
   BackColor       =   &H0000FF00&
   ClientHeight    =   1770
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2010
   ScaleHeight     =   118
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   134
   Begin VB.Timer tmrR 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   720
      Top             =   720
   End
End
Attribute VB_Name = "cScrollBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private slValue As Double
Private slMoving As Boolean
Private slMax, slMin
Private slLargeChange, slSmallChange
Private MDown As Boolean
Private Gphic As Boolean
Private Orien As Boolean

Dim OfY

Public Event Scroll()
Public Event Change()

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type


Private Sub tmrR_Timer()
  If MDown = False Then
    tmrR.Enabled = False
    Draw
    RaiseEvent Change
    Exit Sub
  End If
  If tmrR.Interval <> 50 Then
    tmrR.Interval = 50
  Else
    If tmrR.Tag = "U" Then
      slValue = slValue - slSmallChange
      If slValue < slMin Then slValue = slMin
      Draw
      RaiseEvent Scroll
    End If
    If tmrR.Tag = "D" Then
      slValue = slValue + slSmallChange
      If slValue > slMax Then slValue = slMax
      Draw
      RaiseEvent Scroll
    End If
  End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  MDown = True
  
  Dim CValue, sHeight
  sHeight = ScrollHeight
  CValue = ScrollTop
  Dim Val
  
  Dim XOY
  If Orien = True Then XOY = Y Else XOY = X
  'Y = Y - 17
  XOY = XOY - 17
  
  Dim EndWH
  If Orien = True Then EndWH = UserControl.ScaleHeight - 34 Else EndWH = UserControl.ScaleWidth - 34
  
  If XOY > CValue - (sHeight / 2) And XOY < CValue + (sHeight / 2) Then
    slMoving = True
    Val = XYToVal(XOY - (sHeight / 2))
    OfY = XOY - ScrollTop
    OfY = OfY
  ElseIf XOY < CValue And XOY >= 0 Then
    slValue = slValue - slLargeChange
    If slValue < slMin Then slValue = slMin
    RaiseEvent Scroll
    Draw
  ElseIf XOY < 0 Then
    slValue = slValue - slSmallChange
    If slValue < slMin Then slValue = slMin
    tmrR.Tag = "U": tmrR.Interval = 400
    tmrR.Enabled = True
    RaiseEvent Scroll
    Draw
  ElseIf XOY > CValue And XOY < EndWH Then
    slValue = slValue + slLargeChange
    If slValue > slMax Then slValue = slMax
    RaiseEvent Scroll
    Draw
  ElseIf XOY > EndWH Then
    slValue = slValue + slSmallChange
    If slValue > slMax Then slValue = slMax
    tmrR.Tag = "D": tmrR.Interval = 400
    tmrR.Enabled = True
    RaiseEvent Scroll
    Draw
  End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 And slMoving = True Then
    Dim sHeight

    sHeight = ScrollHeight
    
    Dim Val
    If Orien = True Then
      Val = XYToVal(Y - OfY)
    Else
      Val = XYToVal(X - OfY)
    End If
    slValue = Val

    If slValue < slMin Then slValue = slMin
    If slValue > slMax Then slValue = slMax
    Draw
    RaiseEvent Scroll
  End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  MDown = False
  slMoving = False
  slValue = Int(slValue + 0.5)
  If tmrR.Enabled = False Then RaiseEvent Change
  Draw
End Sub

Private Sub UserControl_Resize()
    If slLargeChange <> Empty Then Draw
End Sub

Private Function XYToVal(XY) As Double
  XY = XY - 17 - (ScrollHeight / 2)
  XYToVal = (XY / FreeSpace) * (slMax - slMin)
  Dim Dis
  Dis = 0 - slMin
  XYToVal = XYToVal - Dis
  XY = XY + 17 + (ScrollHeight / 2)
End Function

Private Function ScrollTop()
  Dim Dis
  Dis = 0 - slMin
  ScrollTop = (FreeSpace * ((slValue + Dis) / (Dif2(slMax, slMin) - 1))) + (ScrollHeight / 2)
End Function

Private Function FreeSpace() As Variant
  If Orien = True Then
    FreeSpace = UserControl.ScaleHeight - 34 - ScrollHeight
  Else
    FreeSpace = UserControl.ScaleWidth - 34 - ScrollHeight
  End If
End Function

Private Function ScrollHeight()
  If Orien = True Then
    ScrollHeight = Abs(slMax - slMin) / slLargeChange
    ScrollHeight = (UserControl.ScaleHeight - 34) / (ScrollHeight + 1)
  Else
    ScrollHeight = Abs(slMax - slMin) / slLargeChange
    ScrollHeight = (UserControl.ScaleWidth - 34) / (ScrollHeight + 1)
  End If
End Function

Sub Draw()
    Cls

    Dim CValue, sHeight
    sHeight = ScrollHeight
    CValue = ScrollTop + 17
    
    Dim r As RECT, D As Boolean
    Dim Mid1, Mid2
    
    If Gphic = False Then
      Rem Draw Bar
      Line (0, 0)-(UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1), vbWhite, BF
      Line (0, 0)-(UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1), RGB(167, 166, 170), B
      Line (1, 1)-(UserControl.ScaleWidth - 2, UserControl.ScaleHeight - 2), RGB(235, 233, 237), B
  
      Rem Draw Scroll bar
      If Orien = True Then
        r = MakeRect(0, CValue - (sHeight / 2), UserControl.ScaleWidth - 1, CValue + (sHeight / 2))
      Else
        r = MakeRect(CValue - (sHeight / 2), 0, CValue + (sHeight / 2), UserControl.ScaleHeight - 1)
      End If
      DrawRectBtn r
      
      Rem Draw Top/Left button
      If Orien = True Then
        r = MakeRect(0, 0, UserControl.ScaleWidth - 1, 16)
      Else
        r = MakeRect(0, 0, 16, UserControl.ScaleHeight - 1)
      End If
      If MDown = True And tmrR.Enabled = True And tmrR.Tag = "U" Then D = True Else D = False
      DrawRectBtn r, D
      
      If D = False Then
        DrawArrow Int((r.Left + r.Right) / 2), Int((r.Top + r.Bottom) / 2), 1
      Else
        DrawArrow Int((r.Left + r.Right) / 2) + 1, Int((r.Top + r.Bottom) / 2 + 1), 1
      End If
      
      Rem Draw Bottom/Right button
      If Orien = True Then
        r = MakeRect(0, UserControl.ScaleHeight - 16, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1)
      Else
        r = MakeRect(UserControl.ScaleWidth - 16, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1)
      End If
      If MDown = True And tmrR.Enabled = True And tmrR.Tag = "D" Then D = True Else D = False
      DrawRectBtn r, D
      
      If D = False Then
        DrawArrow Int((r.Left + r.Right) / 2), Int((r.Top + r.Bottom) / 2), 2
      Else
        DrawArrow Int((r.Left + r.Right) / 2) + 1, Int((r.Top + r.Bottom) / 2 + 1), 2
      End If
    Else
    
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\*********************************\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\**Place to make custom graphics**\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\*********************************\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    
    
      Line (0, 0)-(UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1), vbWhite, BF
      Line (0, 0)-(UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1), vbBlack, B
      
      If Orien = True Then
        r = MakeRect(0, CValue - (sHeight / 2), UserControl.ScaleWidth - 1, CValue + (sHeight / 2))
      Else
        r = MakeRect(CValue - (sHeight / 2), 0, CValue + (sHeight / 2), UserControl.ScaleHeight - 1)
      End If
      
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbBlue, BF
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbRed, B
      
      If Orien = True Then
        r = MakeRect(0, 0, UserControl.ScaleWidth - 1, 16)
      Else
        r = MakeRect(0, 0, 16, UserControl.ScaleHeight - 1)
      End If
      
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbYellow, BF
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbGreen, B
      
      If Orien = True Then
        r = MakeRect(0, UserControl.ScaleHeight - 16, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1)
      Else
        r = MakeRect(UserControl.ScaleWidth - 16, 0, UserControl.ScaleWidth - 1, UserControl.ScaleHeight - 1)
      End If
      
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbYellow, BF
      Line (r.Left, r.Top)-(r.Right, r.Bottom), vbGreen, B
    End If
End Sub

Private Sub DrawArrow(X, Y, D As Integer)
  If D = 1 And Orien = True Then
    Line (X - 1, Y - 1)-(X + 1, Y - 1)
    Line (X - 2, Y)-(X + 2, Y)
    Line (X - 3, Y + 1)-(X + 3, Y + 1)
    Line (X - 4, Y + 2)-(X + 4, Y + 2)
  ElseIf D = 1 And Orien = False Then
    Line (X - 1, Y - 1)-(X - 1, Y + 1)
    Line (X - 0, Y - 2)-(X - 0, Y + 2)
    Line (X + 1, Y - 3)-(X + 1, Y + 3)
    Line (X + 2, Y - 4)-(X + 2, Y + 4)
  ElseIf D = 2 And Orien = True Then
    Line (X - 1, Y + 2)-(X + 1, Y + 2)
    Line (X - 2, Y + 1)-(X + 2, Y + 1)
    Line (X - 3, Y)-(X + 3, Y)
    Line (X - 4, Y - 1)-(X + 4, Y - 1)
  ElseIf D = 2 And Orien = False Then
    Line (X + 2, Y - 1)-(X + 2, Y + 1)
    Line (X + 1, Y - 2)-(X + 1, Y + 2)
    Line (X - 0, Y - 3)-(X - 0, Y + 3)
    Line (X - 1, Y - 4)-(X - 1, Y + 4)
  End If
End Sub

Private Function MakeRect(Left, Top, Right, Bottom) As RECT
  MakeRect.Left = Left
  MakeRect.Top = Top
  MakeRect.Right = Right
  MakeRect.Bottom = Bottom
End Function

Private Sub DrawRectBtn(r As RECT, Optional Down As Boolean = False)
  If Down = False Then
    Line (r.Left, r.Top)-(r.Right, r.Bottom), RGB(235, 233, 237), BF
    
    Line (r.Left, r.Top)-(r.Right, r.Bottom), RGB(133, 135, 140), B
    
    Line (r.Left, r.Top)-(r.Left, r.Bottom), RGB(220, 223, 228)
    Line (r.Left, r.Top)-(r.Right, r.Top), RGB(220, 223, 228)
    
    Line (r.Left + 1, r.Top + 1)-(r.Right - 1, r.Bottom - 1), RGB(167, 166, 170), B
    
    Line (r.Left + 1, r.Top + 1)-(r.Left + 1, r.Bottom - 1), RGB(255, 255, 255)
    Line (r.Left + 1, r.Top + 1)-(r.Right - 1, r.Top + 1), RGB(255, 255, 255)
  Else
    Line (r.Left, r.Top)-(r.Right, r.Bottom), RGB(235, 233, 237), BF
    Line (r.Left, r.Top)-(r.Right, r.Bottom), RGB(167, 166, 170), B
  End If
End Sub

Private Function Dif(N1, N2) As Variant
  Dif = N1 - N2
End Function

Private Function Dif2(N1, N2) As Variant
  Dif2 = N1 - N2 + 1
End Function

Public Property Get SmallChange() As Integer
    SmallChange = slSmallChange
    Draw
End Property

Public Property Let SmallChange(newsc As Integer)
    If newsc < 1 Then newsc = 1
    slSmallChange = newsc
    Draw
End Property

Public Property Get LargeChange() As Integer
    LargeChange = slLargeChange
    Draw
End Property

Public Property Let LargeChange(newlc As Integer)
    If newlc < 1 Then newlc = 1
    slLargeChange = newlc
    Draw
End Property

Public Property Get Min() As Integer
    Min = slMin
End Property

Public Property Let Min(newmin As Integer)
    If newmin < slMax Then
      slMin = newmin
      If slValue < slMin Then slValue = slMin
      Draw
    End If
End Property

Public Property Get Max() As Integer
    Max = slMax
End Property

Public Property Let Max(newmax As Integer)
    If newmax > slMin Then
      slMax = newmax
      If slValue > slMax Then slValue = slMax
      Draw
    End If
End Property

Public Property Get Value() As Double
    Value = Int(slValue + 0.5)
End Property

Public Property Let Value(newval As Double)
    If newval >= slMin And newval <= slMax Then
      slValue = Int(newval + 0.5)
      PropertyChanged "sValue"
      Draw
    End If
End Property

Public Property Get OrientationVert() As Boolean
    OrientationVert = Orien
End Property

Public Property Let OrientationVert(newval As Boolean)
    Orien = newval
    PropertyChanged "OrientationVert"
    Draw
End Property

Public Property Get CustomGraphics() As Boolean
    CustomGraphics = Gphic
End Property

Public Property Let CustomGraphics(newval As Boolean)
    Gphic = newval
    PropertyChanged "CustomGraphics"
    Draw
End Property

Private Sub UserControl_InitProperties()
    slMin = 1
    slMax = 10
    slValue = 1
    slLargeChange = 1
    slSmallChange = 1
    Orien = True
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    slSmallChange = PropBag.ReadProperty("SmallChange", 1)
    slLargeChange = PropBag.ReadProperty("LargeChange", 1)
    slMin = PropBag.ReadProperty("Min", 1)
    slMax = PropBag.ReadProperty("Max", 10)
    slValue = PropBag.ReadProperty("Value", 1)
    Orien = PropBag.ReadProperty("OrientationVert", True)
    Gphic = PropBag.ReadProperty("CustomGraphics", False)
    
    Draw
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "SmallChange", slSmallChange, 1
    PropBag.WriteProperty "LargeChange", slLargeChange, 1
    PropBag.WriteProperty "Min", slMin, 1
    PropBag.WriteProperty "Max", slMax, 10
    PropBag.WriteProperty "Value", slValue, 1
    PropBag.WriteProperty "OrientationVert", Orien, True
    PropBag.WriteProperty "CustomGraphics", Gphic, False
    
    Draw
End Sub