VERSION 5.00
Begin VB.UserControl RangeTool 
   ClientHeight    =   945
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3300
   EditAtDesignTime=   -1  'True
   ScaleHeight     =   63
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   220
   Begin VB.PictureBox shpFill 
      BackColor       =   &H80000001&
      BorderStyle     =   0  'None
      Height          =   105
      Left            =   180
      ScaleHeight     =   105
      ScaleWidth      =   2865
      TabIndex        =   2
      Top             =   390
      Width           =   2865
   End
   Begin VB.PictureBox picBottom 
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   336
      Left            =   30
      MousePointer    =   99  'Custom
      ScaleHeight     =   22
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   25
      TabIndex        =   1
      Top             =   540
      Width           =   372
   End
   Begin VB.PictureBox picTop 
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   336
      Left            =   2850
      MousePointer    =   99  'Custom
      ScaleHeight     =   22
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   25
      TabIndex        =   0
      Top             =   30
      Width           =   372
   End
End
Attribute VB_Name = "RangeTool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Event Change()
Public Event Scroll()

Public Enum rtBorderStyle
    rtFlat = 0
    rtRaised
    rtSunken
    rtBump
    rtEtched
End Enum


Private DrawRange           As Long
Private ValRange            As Long
Private ValDrawRatio        As Single

Private DraggingBottom      As Boolean
Private DraggingTop         As Boolean
Private MouseDownOffset     As Long
Private pOldValue           As Long

Private pMin                As Long
Private pMax                As Long

Private pLowerValue         As Long
Private pLowerLocked        As Boolean
Private pLowerVisible       As Boolean

Private pUpperValue         As Long
Private pUpperLocked        As Boolean
Private pUpperVisible       As Boolean

Private pBorderStyle        As rtBorderStyle

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

Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long

Private Const BDR_INNER = &HC
Private Const BDR_OUTER = &H3
Private Const BDR_RAISED = &H5
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKEN = &HA
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_SUNKENOUTER = &H2

Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)

Private Const BF_ADJUST = &H2000

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)

Private Const BF_DIAGONAL = &H10
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)

Private Const BF_FLAT = &H4000
Private Const BF_MIDDLE = &H800
Private Const BF_MONO = &H8000
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_SOFT = &H1000


Public Property Let BorderStyle(NewStyle As rtBorderStyle)
    pBorderStyle = NewStyle
    Refresh
    PropertyChanged "BorderStyle"
End Property

Public Property Get BorderStyle() As rtBorderStyle
    BorderStyle = pBorderStyle
End Property

Public Property Get Color() As OLE_COLOR
    Color = shpFill.BackColor
End Property

Public Property Let Color(NewColor As OLE_COLOR)
    shpFill.BackColor = NewColor
    PropertyChanged "Color"
End Property

Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(NewEnabled As Boolean)
    UserControl.Enabled = NewEnabled
    PropertyChanged "Enabled"
    picTop.Refresh
    picBottom.Refresh
    Refresh
End Property

Private Function Smallest(Val1 As Variant, Val2 As Variant, Optional Val3 As Variant, Optional Val4 As Variant, Optional Val5 As Variant)
    Dim SmallestVal As Variant
    SmallestVal = Val1
    If Val2 < SmallestVal Then SmallestVal = Val2
    If Not IsMissing(Val3) Then If Val3 < SmallestVal Then SmallestVal = Val3
    If Not IsMissing(Val4) Then If Val4 < SmallestVal Then SmallestVal = Val4
    If Not IsMissing(Val5) Then If Val5 < SmallestVal Then SmallestVal = Val5
    Smallest = SmallestVal
End Function
Private Function Largest(Val1 As Variant, Val2 As Variant, Optional Val3 As Variant, Optional Val4 As Variant, Optional Val5 As Variant)
    Dim LargestVal As Variant
    LargestVal = Val1
    If Val2 > LargestVal Then LargestVal = Val2
    If Not IsMissing(Val3) Then If Val3 > LargestVal Then LargestVal = Val3
    If Not IsMissing(Val4) Then If Val4 > LargestVal Then LargestVal = Val4
    If Not IsMissing(Val5) Then If Val5 > LargestVal Then LargestVal = Val5
    Largest = LargestVal
End Function




Sub UpdatePosition()
    
    'Draw the controls in the correct places
    
    On Error Resume Next
    
    DrawRange = ScaleWidth - 17
    ValRange = pMax - pMin
    
    ValDrawRatio = ValRange / DrawRange


    picTop.Move ((pUpperValue - pMin) / ValRange) * DrawRange, 0
    picBottom.Move ((pLowerValue - pMin) / ValRange) * DrawRange, ScaleHeight - picBottom.Height
    
    shpFill.Move picBottom.Left + 7, _
                 picTop.Height + 4, _
                 Largest(picTop.Left - picBottom.Left, 2), _
                 ScaleHeight - 2 * picBottom.Height - 7
    'Refresh
    
End Sub

Private Sub picBottom_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If pLowerLocked Then Exit Sub
    DraggingBottom = True
    pOldValue = pUpperValue
    MouseDownOffset = X
    picBottom.Refresh
End Sub

Private Sub picBottom_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    Static LastPos As Long
    
    If DraggingBottom Then
        Dim Position     As Long
        
        Position = picBottom.Left + X - MouseDownOffset
        
        If Position < 0 Then Position = 0
        If Position > DrawRange Then Position = DrawRange
        
        pLowerValue = pMin + Position * ValDrawRatio
        If pUpperLocked Then pLowerValue = Smallest(pLowerValue, pOldValue)
        pUpperValue = Largest(pLowerValue, pOldValue)
        
        UpdatePosition
        RaiseEvent Scroll
        PropertyChanged "LowerValue"
        
    End If
    
End Sub


Private Sub picBottom_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    DraggingBottom = False
    UpdatePosition
    picBottom.Refresh
    RaiseEvent Change
    PropertyChanged "LowerValue"
End Sub


Private Sub picBottom_Paint()
    Dim X%
    
    
  '  picBottom.AutoRedraw = True
    
    
    For X% = 0 To 14
        picBottom.Line (0, 14 - X%)-(15, 14 - X%), Ambient.BackColor
        picBottom.Line (X% / 2, 14 - X%)-(14 - X% / 2, 14 - X%), vbButtonFace
    Next X%
    
    
    If pLowerLocked Or Extender.Enabled = False Then
        
        picBottom.Line (1, 13)-(13, 13), vbButtonShadow
        picBottom.Line (7, 1)-(13, 13), vb3DHighlight
        picBottom.Line (0, 14)-(14, 14), vb3DHighlight
        
        picBottom.Line (2, 13)-(8, 1), vb3DHighlight
        picBottom.Line (7, 2)-(13, 13), vbButtonShadow
        picBottom.Line (0, 14)-(7, 0), vbButtonShadow
        
        Exit Sub
    End If
    
    
    If DraggingBottom Then
        picBottom.Line (0, 14)-(7, 0), vb3DDKShadow
        picBottom.Line (1, 13)-(7, 1), vbButtonShadow
        picBottom.Line (7, 2)-(13, 13), vbButtonShadow
        picBottom.Line (1, 13)-(13, 13), vbButtonShadow
        picBottom.Line (7, 0)-(14, 14), vb3DHighlight
        picBottom.Line (0, 14)-(14, 14), vb3DHighlight
    Else
        picBottom.Line (7, 0)-(14, 14), vb3DDKShadow
        picBottom.Line (0, 14)-(14, 14), vb3DDKShadow
        picBottom.Line (7, 1)-(13, 13), vbButtonShadow
        picBottom.Line (1, 13)-(13, 13), vbButtonShadow
        picBottom.Line (0, 14)-(7, 0), vb3DHighlight
        picBottom.Line (1, 13)-(7, 1), vb3DHighlight
    
    End If
    

End Sub


Private Sub picTop_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If pUpperLocked Then Exit Sub
    DraggingTop = True
    pOldValue = pLowerValue
    MouseDownOffset = X
    picTop.Refresh
End Sub

Private Sub picTop_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    If DraggingTop Then
        
        Dim Position&
        
        Position = picTop.Left + X - MouseDownOffset
        
        If Position < 0 Then Position = 0
        If Position > DrawRange Then Position = DrawRange
        
        pUpperValue = pMin + Position * ValDrawRatio
        If pLowerLocked Then pUpperValue = Largest(pUpperValue, pOldValue)
        pLowerValue = Smallest(pUpperValue, pOldValue)
        
        UpdatePosition
        RaiseEvent Scroll
        PropertyChanged "UpperValue"
        
    End If
End Sub


Private Sub picTop_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    DraggingTop = False
    UpdatePosition
    picTop.Refresh
    RaiseEvent Change
    PropertyChanged "UpperValue"
End Sub


Private Sub picTop_Paint()
    Dim X&
    
    For X = 0 To 14
        picTop.Line (0, X)-(15, X), Ambient.BackColor
        picTop.Line (X / 2, X)-(14 - X / 2, X), vbButtonFace
    Next X
    
    If pUpperLocked Or Extender.Enabled = False Then
        
        'Outer Indented
        picTop.Line (1, 1)-(13, 1), vb3DHighlight
        picTop.Line (1, 0)-(7, 12), vb3DHighlight
        picTop.Line (13, 0)-(7, 13), vbButtonShadow
        
        picTop.Line (14, 0)-(7, 14), vb3DHighlight
        picTop.Line (0, 0)-(14, 0), vbButtonShadow
        picTop.Line (0, 0)-(7, 14), vbButtonShadow
        
        Exit Sub
    End If
    
    
    If DraggingTop Then
        'Indented
        picTop.Line (13, 0)-(7, 13), vbButtonShadow
        picTop.Line (14, 0)-(7, 14), vb3DHighlight
        picTop.Line (1, 1)-(13, 1), vbButtonShadow
        picTop.Line (1, 1)-(7, 13), vbButtonShadow
        picTop.Line (0, 0)-(14, 0), vb3DDKShadow
        picTop.Line (0, 0)-(7, 14), vb3DDKShadow
    Else
        'Outdented
        picTop.Line (14, 0)-(7, 14), vb3DDKShadow
        picTop.Line (13, 0)-(7, 13), vbButtonShadow
        picTop.Line (0, 0)-(14, 0), vb3DHighlight
        picTop.Line (0, 0)-(7, 14), vb3DHighlight
    End If
End Sub


Private Sub UserControl_Initialize()

    picTop.Width = 15
    picTop.Height = 15

    picBottom.Width = 15
    picBottom.Height = 15

End Sub

Private Sub UserControl_InitProperties()
    
    BackColor = Ambient.BackColor
    
    pMin = 0
    pMax = 100
    pLowerValue = 25
    pUpperValue = 75
    pLowerVisible = True
    pUpperVisible = True
    pBorderStyle = rtEtched
    picBottom.Visible = True
    picTop.Visible = True
    shpFill.BackColor = vbActiveTitleBar
    
    UpdatePosition
End Sub


Private Sub UserControl_Paint()
    Dim RECT   As RECT
    BackColor = Ambient.BackColor
    
    RECT.Left = 4
    RECT.Top = picTop.Height
    RECT.Right = ScaleWidth - 4
    RECT.Bottom = ScaleHeight - picBottom.Height
    
    If Extender.Enabled Then
        Select Case pBorderStyle
            Case rtBump:    DrawEdge hdc, RECT, EDGE_BUMP, BF_RECT
            Case rtEtched:  DrawEdge hdc, RECT, EDGE_ETCHED, BF_RECT
            Case rtRaised:  Line (4, picTop.Height)-(ScaleWidth - 4, ScaleHeight - picBottom.Height), vbButtonFace, BF
                            DrawEdge hdc, RECT, EDGE_RAISED, BF_RECT
            Case rtSunken:  Line (4, picTop.Height)-(ScaleWidth - 4, ScaleHeight - picBottom.Height), vbButtonFace, BF
                            DrawEdge hdc, RECT, EDGE_SUNKEN, BF_RECT
        End Select
    Else
        DrawEdge hdc, RECT, EDGE_ETCHED, BF_RECT
    End If
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    pMin = PropBag.ReadProperty("Min", 0)
    pMax = PropBag.ReadProperty("Max", 100)
    pLowerValue = PropBag.ReadProperty("LowerValue", 25)
    pUpperValue = PropBag.ReadProperty("UpperValue", 75)
    shpFill.BackColor = PropBag.ReadProperty("Color", vbActiveTitleBar)
    pLowerVisible = PropBag.ReadProperty("LowerVisible", True)
    pUpperVisible = PropBag.ReadProperty("UpperVisible", True)
    pLowerLocked = PropBag.ReadProperty("LowerLocked", False)
    pUpperLocked = PropBag.ReadProperty("UpperLocked", False)
    pBorderStyle = PropBag.ReadProperty("BorderStyle", rtBorderStyle.rtEtched)

    picTop.Visible = pUpperVisible
    picBottom.Visible = pLowerVisible
    picTop.MousePointer = IIf(pUpperLocked, 0, 99)
    picBottom.MousePointer = IIf(pLowerLocked, 0, 99)
    
    UpdatePosition
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    If ScaleHeight < 40 Then Height = 40 * Screen.TwipsPerPixelY
    If ScaleWidth < 40 Then Width = 40 * Screen.TwipsPerPixelX
    
    UpdatePosition
End Sub



Public Property Get Min() As Long
    Min = pMin
End Property

Public Property Let Min(ByVal NewMin As Long)
    If NewMin < 0 Then NewMin = 0
    
    pMin = NewMin
    If pMax < pMin Then pMax = pMin
    
    If pUpperValue > pMax Then pUpperValue = pMax
    If pUpperValue < pMin Then pUpperValue = pMin
    If pLowerValue > pMax Then pLowerValue = pMax
    If pLowerValue < pMin Then pLowerValue = pMin
    
    UpdatePosition
    
    PropertyChanged "Min"
End Property

Public Property Get LowerLocked() As Boolean
    LowerLocked = pLowerLocked
End Property

Public Property Let LowerLocked(ByVal NewValue As Boolean)
    pLowerLocked = NewValue
    PropertyChanged "LowerLocked"
    picBottom.MousePointer = IIf(NewValue, 0, 99)
    picBottom.Refresh
End Property

Public Property Get LowerVisible() As Boolean
    LowerVisible = pLowerVisible
End Property

Public Property Let LowerVisible(ByVal NewValue As Boolean)
    picBottom.Visible = NewValue
    pLowerVisible = NewValue
    PropertyChanged "LowerVisible"
End Property


Public Property Get Max() As Long
    Max = pMax
End Property

Public Property Let Max(ByVal NewMax As Long)
    If NewMax < 0 Then NewMax = 0
    
    pMax = NewMax
    If pMin > pMax Then pMin = pMax
    
    If pUpperValue > pMax Then pUpperValue = pMax
    If pUpperValue < pMin Then pUpperValue = pMin
    If pLowerValue > pMax Then pLowerValue = pMax
    If pLowerValue < pMin Then pLowerValue = pMin
    
    UpdatePosition
    
    PropertyChanged "Max"
End Property




Public Property Get UpperLocked() As Boolean
    UpperLocked = pUpperLocked
End Property

Public Property Let UpperLocked(ByVal NewValue As Boolean)
    pUpperLocked = NewValue
    PropertyChanged "UpperLocked"
    picTop.MousePointer = IIf(NewValue, 0, 99)
    picTop.Refresh
End Property

Public Property Get UpperVisible() As Boolean
    UpperVisible = pUpperVisible
End Property

Public Property Let UpperVisible(ByVal NewValue As Boolean)
    picTop.Visible = NewValue
    pUpperVisible = NewValue
    PropertyChanged "UpperVisible"
End Property

Public Property Get UpperValue() As Long
    UpperValue = pUpperValue
End Property

Public Property Let UpperValue(ByVal NewUpperValue As Long)
    If NewUpperValue < pMin Then NewUpperValue = pMin
    If NewUpperValue > pMax Then NewUpperValue = pMax
    
    pUpperValue = NewUpperValue
    
    If pLowerValue > pUpperValue Then pLowerValue = pUpperValue
    
    UpdatePosition
    
    PropertyChanged "UpperValue"
End Property

Public Property Get LowerValue() As Long
    LowerValue = pLowerValue
End Property

Public Property Let LowerValue(ByVal NewLowerValue As Long)
    If NewLowerValue < pMin Then NewLowerValue = pMin
    If NewLowerValue > pMax Then NewLowerValue = pMax
    
    pLowerValue = NewLowerValue
    
    If pUpperValue < pLowerValue Then pUpperValue = pLowerValue
    
    UpdatePosition
    
    PropertyChanged "LowerValue"
End Property

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    
    PropBag.WriteProperty "Min", pMin, 0
    PropBag.WriteProperty "Max", pMax, 100
    PropBag.WriteProperty "LowerValue", pLowerValue, 25
    PropBag.WriteProperty "UpperValue", pUpperValue, 75
    PropBag.WriteProperty "Color", shpFill.BackColor, vbActiveTitleBar
    PropBag.WriteProperty "LowerVisible", pLowerVisible, True
    PropBag.WriteProperty "UpperVisible", pUpperVisible, True
    PropBag.WriteProperty "LowerLocked", pLowerLocked, False
    PropBag.WriteProperty "UpperLocked", pUpperLocked, False
    PropBag.WriteProperty "BorderStyle", pBorderStyle, rtBorderStyle.rtEtched

End Sub