vbAccelerator - Contents of code file: cSlider.ctl

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

' ======================================================================
' Class:    cSlider
' Filename: cSlider.Ctl
' Author:   SP McMahon
' Date:     14 July 1998
'
' A (very!) simple implementation of the API Slider
' control.
' ======================================================================


'
 ===============================================================================
========
' API Declares:
'
 ===============================================================================
========
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WM_COMMAND = &H111
Private Const WM_COMMNOTIFY = &H44
 
Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
Const ICC_BAR_CLASSES = &H20
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" _
 (iccex As tagInitCommonControlsEx) As Boolean
Private Type RECT
    left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long,
 lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As
 Long
'Private Const TB_ADDSTRINGA = (WM_USER + 28)
Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal
 hInstance As Long, ByVal lpBitmapName As String) As Long
'Public Const DI_MASK = 1 'VBC NR
'Public Const DI_IMAGE = 2 'VBC NR
Private Const DI_NORMAL = 3
'Public Const DI_COMPAT = 4 'VBC NR
 Const HWND_TOPMOST = -1
Const SW_HIDE = 0
Const SW_SHOWNORMAL = 1
 
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOREDRAW = &H8
Const SWP_SHOWWINDOW = &H40

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
' Window Style constants
Const WS_VISIBLE = &H10000000
Const WS_CHILD = &H40000000
Const WS_POPUP = &H80000000

' CreateWindow constants
Const CW_USEDEFAULT = &H80000000
 
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" _
 (ByVal dwExStyle As Long, _
 ByVal lpClassName As String, ByVal lpWindowName As String, _
 ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
 ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, _
 ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
 (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
  As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
  Long) As Long
Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" _
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
  String) As Long
Private Declare Function ShowWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function MoveWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
 ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" _
 (ByVal hwnd As Long) As Long
Private Const WM_PAINT = &HF
Private Const WM_USER = &H400
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_STYLE = (-16)
 Private Const WS_BORDER = &H800000
Private Const WM_DRAWITEM = &H2B
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WM_SETREDRAW = &HB
'//Common Control Constants
Private Const CCS_TOP = &H1
Private Const CCS_NOMOVEY = &H2
Private Const CCS_BOTTOM = &H3
Private Const CCS_NORESIZE = &H4
Private Const CCS_NOPARENTALIGN = &H8
'Private Const CCS_ADJUSTABLE          &H00020L
Private Const CCS_NODIVIDER = &H40
'Private Const CCS_VERT                &H00080L
'Private Const CCS_LEFT                (CCS_VERT | CCS_TOP)
'Private Const CCS_RIGHT               (CCS_VERT | CCS_BOTTOM)
'Private Const CCS_NOMOVEX             (CCS_VERT | CCS_NOMOVEY)
 
 
Private Declare Function SetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal
 nIndex As Long, ByVal wNewWord As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Const TRACKBAR_CLASSA = "msctls_trackbar32"
 
Private Const TBS_AUTOTICKS = &H1
Private Const TBS_VERT = &H2
Private Const TBS_HORZ = &H0
Private Const TBS_TOP = &H4
Private Const TBS_BOTTOM = &H0
Private Const TBS_LEFT = &H4
Private Const TBS_RIGHT = &H0
Private Const TBS_BOTH = &H8
Private Const TBS_NOTICKS = &H10
Private Const TBS_ENABLESELRANGE = &H20
Private Const TBS_FIXEDLENGTH = &H40
Private Const TBS_NOTHUMB = &H80
Private Const TBS_TOOLTIPS = &H100
'"TB_THUMPOSITION"
Private Const TBM_GETPOS = (WM_USER)
Private Const TBM_GETRANGEMIN = (WM_USER + 1)
Private Const TBM_GETRANGEMAX = (WM_USER + 2)
Private Const TBM_GETTIC = (WM_USER + 3)
Private Const TBM_SETTIC = (WM_USER + 4)
Private Const TBM_SETPOS = (WM_USER + 5)
Private Const TBM_SETRANGE = (WM_USER + 6)
Private Const TBM_SETRANGEMIN = (WM_USER + 7)
Private Const TBM_SETRANGEMAX = (WM_USER + 8)
Private Const TBM_CLEARTICS = (WM_USER + 9)
Private Const TBM_SETSEL = (WM_USER + 10)
Private Const TBM_SETSELSTART = (WM_USER + 11)
Private Const TBM_SETSELEND = (WM_USER + 12)
Private Const TBM_GETPTICS = (WM_USER + 14)
Private Const TBM_GETTICPOS = (WM_USER + 15)
Private Const TBM_GETNUMTICS = (WM_USER + 16)
Private Const TBM_GETSELSTART = (WM_USER + 17)
Private Const TBM_GETSELEND = (WM_USER + 18)
Private Const TBM_CLEARSEL = (WM_USER + 19)
Private Const TBM_SETTICFREQ = (WM_USER + 20)
Private Const TBM_SETPAGESIZE = (WM_USER + 21)
Private Const TBM_GETPAGESIZE = (WM_USER + 22)
Private Const TBM_SETLINESIZE = (WM_USER + 23)
Private Const TBM_GETLINESIZE = (WM_USER + 24)
Private Const TBM_GETTHUMBRECT = (WM_USER + 25)
Private Const TBM_GETCHANNELRECT = (WM_USER + 26)
Private Const TBM_SETTHUMBLENGTH = (WM_USER + 27)
Private Const TBM_GETTHUMBLENGTH = (WM_USER + 28)
Private Const TBM_SETTOOLTIPS = (WM_USER + 29)
Private Const TBM_GETTOOLTIPS = (WM_USER + 30)
Private Const TBM_SETTIPSIDE = (WM_USER + 31)
'// TrackBar Tip Side flags
Private Const TBTS_TOP = 0
Private Const TBTS_LEFT = 1
Private Const TBTS_BOTTOM = 2
Private Const TBTS_RIGHT = 3

Private Const TBM_SETBUDDY = (WM_USER + 32) ' // wparam = BOOL fLeft; (or right)
Private Const TBM_GETBUDDY = (WM_USER + 33) ' // wparam = BOOL fLeft; (or right)


Private Const TB_LINEUP = 0
Private Const TB_LINEDOWN = 1
Private Const TB_PAGEUP = 2
Private Const TB_PAGEDOWN = 3
Private Const TB_THUMBPOSITION = 4
Private Const TB_THUMBTRACK = 5
Private Const TB_TOP = 6
Private Const TB_BOTTOM = 7
Private Const TB_ENDTRACK = 8


'// custom draw item specs
Private Const TBCD_TICS = &H1
Private Const TBCD_THUMB = &H2
Private Const TBCD_CHANNEL = &H3


'
 ===============================================================================
========
' Implementation
'
 ===============================================================================
========
Public Enum ESliderOrientation
    eslHorizontal = TBS_HORZ
    eslVertical = TBS_VERT
End Enum
Private m_eOrientation As ESliderOrientation
Private m_hWNd As Long
Private m_bSubClass As Boolean
Private m_lMin As Long
Private m_lMax As Long
Private m_lValue As Long

Implements ISubclass
Private m_emr As EMsgResponse

Public Event Scroll(ByVal lPos As Long)

Public Property Get Min() As Long
    Min = m_lMin
End Property
Public Property Let Min(ByVal lMin As Long)
    If (m_lMin <> lMin) Then
        m_lMin = lMin
        If (m_lMax < m_lMin) Then
            m_lMax = m_lMin + 1
        End If
        SetRange m_lMin, m_lMax
    End If
End Property

Public Property Get Max() As Long
    Max = m_lMax
End Property
Public Property Let Max(ByVal lMax As Long)
    If (m_lMax <> lMax) Then
        m_lMax = lMax
        If (m_lMin > m_lMax) Then
            m_lMin = m_lMax - 1
        End If
        SetRange m_lMin, m_lMax
    End If
End Property
Public Property Get Value() As Long
    If (m_hWNd <> 0) Then
        Value = SendMessageLong(m_hWNd, TBM_GETPOS, 0, 0)
    Else
        Value = m_lValue
    End If
End Property
Public Property Let Value(ByVal lValue As Long)
    If (m_lValue <> lValue) Then
        m_lValue = lValue
        If (m_hWNd <> 0) Then
            SendMessageLong m_hWNd, TBM_SETPOS, 1, lValue
        End If
    End If
End Property
Public Sub SetRange(ByVal lMin As Long, ByVal lMax As Long)
    SendMessageLong m_hWNd, TBM_SETRANGEMIN, True, lMin
    SendMessageLong m_hWNd, TBM_SETRANGEMAX, True, lMax
End Sub
Public Property Get Orientation() As ESliderOrientation
    Orientation = m_eOrientation
End Property
Public Property Let Orientation(ByVal eOrientation As ESliderOrientation)
    m_eOrientation = eOrientation
End Property

Private Sub pInitialise()
Dim dwStyle As Long
Dim iccex As tagInitCommonControlsEx

    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_BAR_CLASSES
    End With
    InitCommonControlsEx iccex

    dwStyle = WS_CHILD Or WS_VISIBLE Or TBTS_LEFT Or TBS_RIGHT
    If (m_eOrientation = eslHorizontal) Then
        dwStyle = dwStyle Or TBS_HORZ
    Else
        dwStyle = dwStyle Or TBS_VERT
    End If
    
    m_hWNd = CreateWindowEX(0, TRACKBAR_CLASSA, "", _
                dwStyle, 0, 0, 0, 0, _
                UserControl.hwnd, 0&, App.hInstance, 0&)
    If (m_hWNd <> 0) Then
        SendMessageLong m_hWNd, TBM_SETTICFREQ, 10, 0
        ' (Minimum range = low word, Maximum range = high word)
        SendMessageLong m_hWNd, TBM_SETRANGE, True, 100 * &H10000
                
        SetParent m_hWNd, UserControl.hwnd
        UserControl_Resize
        ShowWindow m_hWNd, SW_SHOWNORMAL
        
        If (UserControl.Ambient.UserMode) Then
            AttachMessage Me, UserControl.hwnd, WM_HSCROLL
            AttachMessage Me, UserControl.hwnd, WM_VSCROLL
            m_bSubClass = True
        End If
    End If
End Sub
Private Sub pTerminate()
    If (m_hWNd <> 0) Then
        ShowWindow m_hWNd, SW_HIDE
        SetParent m_hWNd, 0
        DestroyWindow m_hWNd
    End If
End Sub

Private Property Let ISubClass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
    m_emr = RHS
End Property

Private Property Get ISubClass_MsgResponse() As SSubTimer.EMsgResponse
    ISubClass_MsgResponse = emrPreprocess
End Property

Private Function ISubClass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lPos As Long
    lPos = Value
    RaiseEvent Scroll(lPos)
End Function

Private Sub UserControl_Initialize()
    m_lMin = 1
    m_lMax = 100
End Sub

Private Sub UserControl_InitProperties()
    pInitialise
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Orientation = PropBag.ReadProperty("Orientation", TBS_HORZ)
    pInitialise
    Min = PropBag.ReadProperty("Min", 1)
    Max = PropBag.ReadProperty("Max", 100)
    Value = PropBag.ReadProperty("Value", 1)
End Sub

Private Sub UserControl_Resize()
    If (m_hWNd <> 0) Then
        MoveWindow m_hWNd, 0, 0, UserControl.ScaleWidth \
         Screen.TwipsPerPixelX, UserControl.ScaleHeight \
         Screen.TwipsPerPixelY, 1
    End If
End Sub

Private Sub UserControl_Terminate()
    If (m_bSubClass) Then
        DetachMessage Me, UserControl.hwnd, WM_HSCROLL
        DetachMessage Me, UserControl.hwnd, WM_VSCROLL
    End If
    pTerminate
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Orientation", Orientation, eslHorizontal
    PropBag.WriteProperty "Min", Min, 1
    PropBag.WriteProperty "Max", Max, 100
    PropBag.WriteProperty "Value", Value, 1
End Sub