Не мозоль мож кто другой ответит

Не мозоль мож кто другой ответит

Я не жму ссылку форум я полный адресс ввожу сразу

http://www.vbnet.ru/samples - сплошь мусор и неразбериха

VERSION 5.00
Begin VB.UserControl SplitBar
   AutoRedraw      =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
End
Attribute VB_Name = "SplitBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'***************************************************************************************
'*                     Написано: 07.31.2005 (Team HomeWork)                            *
'*                           e-mail: sne_pro@mail.ru                                   *
'***************************************************************************************

Private Enum prEvent
    drgStarted = 0&
    drgProgress = 1&
    drgFinished = 2&
End Enum

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Переменные §§§§§§§§§§§§§§§§§§§§§§§§§§

Private m_Vertical      As Boolean, _
        m_DoWork        As Boolean

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Свойства §§§§§§§§§§§§§§§§§§§§§§§§§§

Private m_LiteLine      As Long, _
        m_DarkLine      As Long, _
        m_MinValue      As Long, _
        m_MaxValue      As Long

' §§§§§§§§§§§§§§§§§§§§§§§§§§ События §§§§§§§§§§§§§§§§§§§§§§§§§§

Public Event DragBegin(ByVal pos1 As Long, ByVal pos2 As Long)
Public Event DragProgress(ByRef pos1 As Long, ByRef pos2 As Long)
Public Event DragEnd(ByVal pos1 As Long, ByVal pos2 As Long)

' §§§§§§§§§§§§§§§§§§§§§§§§§§ UserControl events §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Sub UserControl_InitProperties()
    m_DarkLine = vb3DShadow
    m_LiteLine = vb3DHighlight
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then Call DoDragEvents(drgStarted, x, y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then Call DoDragEvents(drgProgress, x, y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then Call DoDragEvents(drgFinished, x, y)
End Sub

Private Sub UserControl_Show()
    Call DrawSplitBar
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_LiteLine = PropBag.ReadProperty("ColorLite", vb3DHighlight)
    m_DarkLine = PropBag.ReadProperty("ColorDark", vb3DShadow)
    m_MinValue = PropBag.ReadProperty("MinValue", 0&
    m_MaxValue = PropBag.ReadProperty("MaxValue", 0&
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("ColorLite", m_LiteLine, vb3DHighlight)
    Call PropBag.WriteProperty("ColorDark", m_DarkLine, vb3DShadow)
    Call PropBag.WriteProperty("MinValue", m_MinValue, 0&
    Call PropBag.WriteProperty("MaxValue", m_MaxValue, 0&
End Sub

Private Sub UserControl_Resize()
    Dim c_size  As Long

    m_Vertical = (UserControl.Width < UserControl.Height)

    If m_Vertical Then
        c_size = UserControl.Width - (UserControl.Width Mod (3 * Screen.TwipsPerPixelX))
    Else
        c_size = UserControl.Height - (UserControl.Height Mod (3 * Screen.TwipsPerPixelY))
    End If

    If (c_size < (3& * Screen.TwipsPerPixelX)) Then _
        c_size = (3& * Screen.TwipsPerPixelX)

    If (c_size > (15& * Screen.TwipsPerPixelX)) Then _
        c_size = (15& * Screen.TwipsPerPixelX)

    If m_Vertical Then
        UserControl.Width = c_size
        UserControl.MousePointer = vbSizeWE

    Else
        UserControl.Height = c_size
        UserControl.MousePointer = vbSizeNS

    End If

    Call DrawSplitBar
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Properties §§§§§§§§§§§§§§§§§§§§§§§§§§

Public Property Get BackColor() As OLE_COLOR                    ' Цвет фона
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal Value As OLE_COLOR)
    UserControl.BackColor = Value
    Call DrawSplitBar
End Property

Public Property Get LineLite() As OLE_COLOR                     ' Цвет первой линии
    LineLite = m_LiteLine
End Property

Public Property Let LineLite(ByVal Value As OLE_COLOR)
    m_LiteLine = Value
    Call DrawSplitBar
End Property

Public Property Get LineDark() As OLE_COLOR                     ' Цвет второй линии
    LineDark = m_DarkLine
End Property

Public Property Let LineDark(ByVal Value As OLE_COLOR)
    m_DarkLine = Value
    Call DrawSplitBar
End Property

Public Property Get MaxValue() As Long
    MaxValue = m_MaxValue
End Property

Public Property Let MaxValue(ByVal Value As Long)
    m_MaxValue = Value
End Property

Public Property Get MinValue() As Long
    MinValue = m_MinValue
End Property

Public Property Let MinValue(ByVal Value As Long)
    m_MinValue = Value
End Property

' §§§§§§§§§§§§§§§§§§§§§§§§§§ My stuff §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Sub DrawSplitBar()
    Dim cur_cnt As Long

    With UserControl
        Call .Cls
        cur_cnt = IIf(m_Vertical, UserControl.Width, UserControl.Height) \ 2&
        
        If (m_Vertical) Then
            .ForeColor = m_DarkLine                             ' Темная линия
            UserControl.Line (cur_cnt, 0&-(cur_cnt, .ScaleHeight)
            cur_cnt = cur_cnt + Screen.TwipsPerPixelX

            .ForeColor = m_LiteLine                             ' Светлая линия
            UserControl.Line (cur_cnt, 0&-(cur_cnt, .ScaleHeight)

        Else
            .ForeColor = m_DarkLine                             ' Темная линия
            UserControl.Line (0&, cur_cnt)-(.ScaleWidth, cur_cnt)
            cur_cnt = cur_cnt + Screen.TwipsPerPixelX

            .ForeColor = m_LiteLine                             ' Светлая линия
            UserControl.Line (0&, cur_cnt)-(.ScaleWidth, cur_cnt)

        End If
    End With
End Sub

Private Sub DoDragEvents(ByVal iEvent As prEvent, ByVal x As Long, ByVal y As Long)
    On Error Resume Next

    Dim indx    As Long, _
        lng1    As Long, _
        lng2    As Long, _
        sName   As String

    With UserControl.ParentControls                             ' Находим нашконтрол по имени
        For indx = 0 To .Count - vbNull
            sName = .Item(indx).Name
            sName = sName & "" & CStr(.Item(indx).Index) & ""

            If (UserControl.Ambient.DisplayName = sName) Then _
                Exit For
        Next
    End With

    With UserControl.ParentControls(indx)                       ' И работаем только с ним
        If (m_Vertical) Then
            lng1 = .Left + x                                    ' Новая левая граница
            lng2 = .Width + lng1                                ' Новая правая граница
    
        Else
            lng1 = .Top + y                                     ' Аналогично
            lng2 = .Height + lng1
    
        End If

        If Not (m_MinValue = 0& Then
            Debug.Print lng1, lng2
            If (lng1 < m_MinValue) Then lng1 = m_MinValue
            If (lng2 < m_MinValue) Then lng2 = m_MinValue
        End If
        If Not (m_MaxValue = 0& Then
            If (lng1 > m_MaxValue) Then lng1 = m_MaxValue
            If (lng2 > m_MaxValue) Then lng2 = m_MaxValue
        End If

        Select Case iEvent
            Case Is = drgStarted                                ' Начало
                m_DoWork = True
                RaiseEvent DragBegin(lng1, lng2)

            Case Is = drgProgress                               ' В состоянии
                If Not (m_DoWork) Then Exit Sub
    
                Call .ZOrder(0)                                 ' Слайдер должно быть видно
                RaiseEvent DragProgress(lng1, lng2)
                If (m_Vertical) Then .Left = lng1 Else .Top = lng1

            Case Is = drgFinished                               ' Закончили...
                m_DoWork = False
                RaiseEvent DragEnd(lng1, lng2)

        End Select
    End With
End Sub