home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Image_Outl1946381152005.psc / cScrollBars.cls < prev    next >
Text File  |  2005-09-14  |  24KB  |  678 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cScrollBars"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' ===========================================================================
  17. ' Name:     cScrollBars
  18. ' Author:   Steve McMahon (steve@vbaccelerator.com)
  19. ' Date:     24 December 1998
  20. ' Requires: SSUBTMR.DLL
  21. '
  22. ' ---------------------------------------------------------------------------
  23. ' Copyright « 1998 Steve McMahon (steve@vbaccelerator.com)
  24. ' Visit vbAccelerator - free, advanced source code for VB programmers.
  25. '     http://vbaccelerator.com
  26. ' ---------------------------------------------------------------------------
  27. '
  28. ' Description:
  29. ' A class which can add scroll bars to VB Forms, Picture Boxes and
  30. ' UserControls.
  31. ' Features:
  32. '  * True API scroll bars, which don't flash or draw badly like
  33. '    the VB ones
  34. '  * Scroll bar values are long integers, i.e. >2 billion values
  35. '  * Set Flat or Encarta scroll bar modes if your COMCTL32.DLL version
  36. '    supports it (>4.72)
  37. '
  38. ' Updates:
  39. ' 2003-07-02
  40. '  * Added Mouse Wheel Support.  Thanks to Chris Eastwood for
  41. '    the suggestion and starter code.
  42. '    Visit his site at http://vbcodelibrary.co.uk/
  43. '  * Scroll bar now goes to bottom when SB_BOTTOM fired
  44. '    (e.g. right click on scroll bar with mouse)
  45. '  * New ScrollClick events to enable focus
  46. '  * Removed a large quantity of redundant declares which
  47. '    had found their way into this class somehow...
  48. ' ===========================================================================
  49.  
  50.  
  51. ' ---------------------------------------------------------------------
  52. ' vbAccelerator Software License
  53. ' Version 1.0
  54. ' Copyright (c) 2002 vbAccelerator.com
  55. '
  56. ' Redistribution and use in source and binary forms, with or
  57. ' without modification, are permitted provided that the following
  58. ' conditions are met:
  59. '
  60. ' 1. Redistributions of source code must retain the above copyright
  61. '    notice, this list of conditions and the following disclaimer.
  62. '
  63. ' 2. Redistributions in binary form must reproduce the above copyright
  64. '    notice, this list of conditions and the following disclaimer in
  65. '    the documentation and/or other materials provided with the distribution.
  66. '
  67. ' 3. The end-user documentation included with the redistribution, if any,
  68. '    must include the following acknowledgment:
  69. '
  70. '  "This product includes software developed by vbAccelerator (http://vbaccelerator.com/)."
  71. '
  72. ' Alternately, this acknowledgment may appear in the software itself, if
  73. ' and wherever such third-party acknowledgments normally appear.
  74. '
  75. ' 4. The name "vbAccelerator" must not be used to endorse or promote products
  76. '    derived from this software without prior written permission. For written
  77. '    permission, please contact vbAccelerator through steve@vbaccelerator.com.
  78. '
  79. ' 5. Products derived from this software may not be called "vbAccelerator",
  80. '    nor may "vbAccelerator" appear in their name, without prior written
  81. '    permission of vbAccelerator.
  82. '
  83. ' THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED WARRANTIES,
  84. ' INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  85. ' AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
  86. ' VBACCELERATOR OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  87. ' INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  88. ' BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
  89. ' USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  90. ' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  91. ' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  92. ' THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  93. '
  94. ' ---------------------------------------------------------------------
  95.  
  96. Private Type OSVERSIONINFO
  97.     dwOSVersionInfoSize As Long
  98.     dwMajorVersion As Long
  99.     dwMinorVersion As Long
  100.     dwBuildNumber As Long
  101.     dwPlatformId As Long
  102.     szCSDVersion As String * 128      '  Maintenance string for PSS usage
  103. End Type
  104.  
  105. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
  106. Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
  107. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Long, ByVal fuWinIni As Long) As Long
  108.  
  109. 'private declare function InitializeFlatSB(HWND) as long
  110. Private Declare Function InitialiseFlatSB Lib "comctl32.dll" Alias "InitializeFlatSB" (ByVal lHWnd As Long) As Long
  111.  
  112. ' Scroll bar:
  113. Private Type SCROLLINFO
  114.     cbSize As Long
  115.     fMask As Long
  116.     nMin As Long
  117.     nMax As Long
  118.     nPage As Long
  119.     nPos As Long
  120.     nTrackPos As Long
  121. End Type
  122. Private Declare Function SetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal BOOL As Boolean) As Long
  123. Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, LPSCROLLINFO As SCROLLINFO) As Long
  124. Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
  125. Private Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
  126. Private Declare Function SetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
  127. Private Declare Function SetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
  128.     Private Const SB_BOTH = 3
  129.     Private Const SB_BOTTOM = 7
  130.     Private Const SB_CTL = 2
  131.     Private Const SB_ENDSCROLL = 8
  132.     Private Const SB_HORZ = 0
  133.     Private Const SB_LEFT = 6
  134.     Private Const SB_LINEDOWN = 1
  135.     Private Const SB_LINELEFT = 0
  136.     Private Const SB_LINERIGHT = 1
  137.     Private Const SB_LINEUP = 0
  138.     Private Const SB_PAGEDOWN = 3
  139.     Private Const SB_PAGELEFT = 2
  140.     Private Const SB_PAGERIGHT = 3
  141.     Private Const SB_PAGEUP = 2
  142.     Private Const SB_RIGHT = 7
  143.     Private Const SB_THUMBPOSITION = 4
  144.     Private Const SB_THUMBTRACK = 5
  145.     Private Const SB_TOP = 6
  146.     Private Const SB_VERT = 1
  147.  
  148.     Private Const SIF_RANGE = &H1
  149.     Private Const SIF_PAGE = &H2
  150.     Private Const SIF_POS = &H4
  151.     Private Const SIF_DISABLENOSCROLL = &H8
  152.     Private Const SIF_TRACKPOS = &H10
  153.     Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
  154.  
  155.    Private Const ESB_DISABLE_BOTH = &H3
  156.    Private Const ESB_ENABLE_BOTH = &H0
  157.    
  158.    Private Const SBS_SIZEGRIP = &H10&
  159.    
  160. Private Declare Function EnableScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wSBflags As Long, ByVal wArrows As Long) As Long
  161. Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long
  162.  
  163. ' Non-client messages:
  164. Private Const WM_NCLBUTTONDOWN = &HA1
  165. Private Const WM_NCRBUTTONDOWN = &HA4
  166. Private Const WM_NCMBUTTONDOWN = &HA7
  167.  
  168. ' Hit test codes for scroll bars:
  169. Private Const HTHSCROLL = 6
  170. Private Const HTVSCROLL = 7
  171.  
  172. ' Scroll bar messages:
  173. Private Const WM_VSCROLL = &H115
  174. Private Const WM_HSCROLL = &H114
  175. Private Const WM_MOUSEWHEEL = &H20A
  176.  
  177. ' Mouse wheel stuff:
  178. Private Const WHEEL_DELTA = 120
  179. Private Const WHEEL_PAGESCROLL = -1
  180. Private Const SPI_GETWHEELSCROLLLINES = &H68
  181.  
  182. ' Old school Wheel Mouse is not supported in this class.
  183. ' NT3.51 or Win95 only
  184. '// Class name for MSWHEEL.EXE's invisible window
  185. '// use FindWindow to get hwnd to MSWHEEL
  186. Private Const MSH_MOUSEWHEEL = "MSWHEEL_ROLLMSG"
  187. Private Const MSH_WHEELMODULE_CLASS = "MouseZ"
  188. Private Const MSH_WHEELMODULE_TITLE = "Magellan MSWHEEL"
  189. '// Apps need to call RegisterWindowMessage using the #defines
  190. '// below to get the message numbers for:
  191. '// 1) the message that can be sent to the MSWHEEL window to
  192. '//    query if wheel support is active (MSH_WHEELSUPPORT)>
  193. '// 2) the message to query for the number of scroll lines
  194. '//    (MSH_SCROLL_LINES)
  195. '//
  196. '// To send a message to MSWheel window, use FindWindow with the #defines
  197. '// for CLASS and TITLE above.  If FindWindow fails to find the MSWHEEL
  198. '// window or the return from SendMessage is false, then Wheel support
  199. '// is not currently available.
  200. Private Const MSH_WHEELSUPPORT = "MSH_WHEELSUPPORT_MSG"
  201. Private Const MSH_SCROLL_LINES = "MSH_SCROLL_LINES_MSG"
  202.  
  203. ' Flat scroll bars:
  204. Private Const WSB_PROP_CYVSCROLL = &H1&
  205. Private Const WSB_PROP_CXHSCROLL = &H2&
  206. Private Const WSB_PROP_CYHSCROLL = &H4&
  207. Private Const WSB_PROP_CXVSCROLL = &H8&
  208. Private Const WSB_PROP_CXHTHUMB = &H10&
  209. Private Const WSB_PROP_CYVTHUMB = &H20&
  210. Private Const WSB_PROP_VBKGCOLOR = &H40&
  211. Private Const WSB_PROP_HBKGCOLOR = &H80&
  212. Private Const WSB_PROP_VSTYLE = &H100&
  213. Private Const WSB_PROP_HSTYLE = &H200&
  214. Private Const WSB_PROP_WINSTYLE = &H400&
  215. Private Const WSB_PROP_PALETTE = &H800&
  216. Private Const WSB_PROP_MASK = &HFFF&
  217.  
  218. Private Const FSB_FLAT_MODE = 2&
  219. Private Const FSB_ENCARTA_MODE = 1&
  220. Private Const FSB_REGULAR_MODE = 0&
  221.  
  222. Private Declare Function FlatSB_EnableScrollBar Lib "comctl32.dll" (ByVal hwnd As Long, ByVal int2 As Long, ByVal UINT3 As Long) As Long
  223. Private Declare Function FlatSB_ShowScrollBar Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal fRedraw As Boolean) As Long
  224.  
  225. Private Declare Function FlatSB_GetScrollRange Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal LPINT1 As Long, ByVal LPINT2 As Long) As Long
  226. Private Declare Function FlatSB_GetScrollInfo Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, LPSCROLLINFO As SCROLLINFO) As Long
  227. Private Declare Function FlatSB_GetScrollPos Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long) As Long
  228. Private Declare Function FlatSB_GetScrollProp Lib "comctl32.dll" (ByVal hwnd As Long, ByVal propIndex As Long, ByVal LPINT As Long) As Long
  229.  
  230. Private Declare Function FlatSB_SetScrollPos Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal pos As Long, ByVal fRedraw As Boolean) As Long
  231. Private Declare Function FlatSB_SetScrollInfo Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, LPSCROLLINFO As SCROLLINFO, ByVal fRedraw As Boolean) As Long
  232. Private Declare Function FlatSB_SetScrollRange Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal Min As Long, ByVal Max As Long, ByVal fRedraw As Boolean) As Long
  233. Private Declare Function FlatSB_SetScrollProp Lib "comctl32.dll" (ByVal hwnd As Long, ByVal index As Long, ByVal newValue As Long, ByVal fRedraw As Boolean) As Long
  234.  
  235. Private Declare Function InitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As Long) As Long
  236. Private Declare Function UninitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As Long) As Long
  237.  
  238.  
  239. ' Message response:
  240. Implements ISubclass
  241. Private m_emr As EMsgResponse
  242.  
  243. ' Initialisation state:
  244. Private m_bInitialised As Boolean
  245.  
  246. ' Orientation
  247. Public Enum EFSOrientationConstants
  248.     efsoHorizontal
  249.     efsoVertical
  250.     efsoBoth
  251. End Enum
  252. Private m_eOrientation As EFSOrientationConstants
  253.  
  254. ' Style
  255. Public Enum EFSStyleConstants
  256.     efsRegular = FSB_REGULAR_MODE
  257.     efsEncarta = FSB_ENCARTA_MODE
  258.     efsFlat = FSB_FLAT_MODE
  259. End Enum
  260. Private m_eStyle As EFSStyleConstants
  261. ' Bars:
  262. Public Enum EFSScrollBarConstants
  263.    efsHorizontal = SB_HORZ
  264.    efsVertical = SB_VERT
  265. End Enum
  266.  
  267. ' Can we have flat scroll bars?
  268. Private m_bNoFlatScrollBars As Boolean
  269.  
  270. ' hWnd we're adding scroll bars too:
  271. Private m_hWnd As Long
  272.  
  273. ' Small change amount
  274. Private m_lSmallChangeHorz As Long
  275. Private m_lSmallChangeVert As Long
  276. ' Enabled:
  277. Private m_bEnabledHorz As Boolean
  278. Private m_bEnabledVert As Boolean
  279. ' Visible
  280. Private m_bVisibleHorz As Boolean
  281. Private m_bVisibleVert As Boolean
  282.  
  283. ' Number of lines to scroll for each wheel click:
  284. Private m_lWheelScrollLines  As Long
  285.  
  286. Public Event ScrollClick(eBar As EFSScrollBarConstants, eButton As MouseButtonConstants)
  287. Public Event Scroll(eBar As EFSScrollBarConstants)
  288. Public Event Change(eBar As EFSScrollBarConstants)
  289. Public Event MouseWheel(eBar As EFSScrollBarConstants, lAmount As Long)
  290.  
  291. Public Property Get Visible(ByVal eBar As EFSScrollBarConstants) As Boolean
  292.    If (eBar = efsHorizontal) Then
  293.       Visible = m_bVisibleHorz
  294.    Else
  295.       Visible = m_bVisibleVert
  296.    End If
  297. End Property
  298. Public Property Let Visible(ByVal eBar As EFSScrollBarConstants, ByVal bState As Boolean)
  299.    If (eBar = efsHorizontal) Then
  300.       m_bVisibleHorz = bState
  301.    Else
  302.       m_bVisibleVert = bState
  303.    End If
  304.    If (m_bNoFlatScrollBars) Then
  305.       ShowScrollBar m_hWnd, eBar, Abs(bState)
  306.    Else
  307.       FlatSB_ShowScrollBar m_hWnd, eBar, Abs(bState)
  308.    End If
  309. End Property
  310.  
  311. Public Property Get Orientation() As EFSOrientationConstants
  312.    Orientation = m_eOrientation
  313. End Property
  314.  
  315. Public Property Let Orientation(ByVal eOrientation As EFSOrientationConstants)
  316.    m_eOrientation = eOrientation
  317.    pSetOrientation
  318. End Property
  319.  
  320. Private Sub pSetOrientation()
  321.    ShowScrollBar m_hWnd, SB_HORZ, Abs((m_eOrientation = efsoBoth) Or (m_eOrientation = efsoHorizontal))
  322.    ShowScrollBar m_hWnd, SB_VERT, Abs((m_eOrientation = efsoBoth) Or (m_eOrientation = efsoVertical))
  323. End Sub
  324.  
  325. Private Sub pGetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As SCROLLINFO, ByVal fMask As Long)
  326. Dim lO As Long
  327.     
  328.     lO = eBar
  329.     tSI.fMask = fMask
  330.     tSI.cbSize = LenB(tSI)
  331.     
  332.     If (m_bNoFlatScrollBars) Then
  333.         GetScrollInfo m_hWnd, lO, tSI
  334.     Else
  335.         FlatSB_GetScrollInfo m_hWnd, lO, tSI
  336.     End If
  337.  
  338. End Sub
  339. Private Sub pLetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As SCROLLINFO, ByVal fMask As Long)
  340. Dim lO As Long
  341.         
  342.     lO = eBar
  343.     tSI.fMask = fMask
  344.     tSI.cbSize = LenB(tSI)
  345.     
  346.     If (m_bNoFlatScrollBars) Then
  347.         SetScrollInfo m_hWnd, lO, tSI, True
  348.     Else
  349.         FlatSB_SetScrollInfo m_hWnd, lO, tSI, True
  350.     End If
  351.     
  352. End Sub
  353.  
  354. Public Property Get Style() As EFSStyleConstants
  355.    Style = m_eStyle
  356. End Property
  357. Public Property Let Style(ByVal eStyle As EFSStyleConstants)
  358. Dim lR As Long
  359.    If (eStyle <> efsRegular) Then
  360.       If (m_bNoFlatScrollBars) Then
  361.          ' can't do it..
  362.          Debug.Print "Can't set non-regular style mode on this system - COMCTL32.DLL version < 4.71."
  363.          Exit Property
  364.       End If
  365.    End If
  366.    If (m_eOrientation = efsoHorizontal) Or (m_eOrientation = efsoBoth) Then
  367.       lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_HSTYLE, eStyle, True)
  368.    End If
  369.    If (m_eOrientation = efsoVertical) Or (m_eOrientation = efsoBoth) Then
  370.       lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_VSTYLE, eStyle, True)
  371.    End If
  372.    m_eStyle = eStyle
  373. End Property
  374.  
  375. Public Property Get SmallChange(ByVal eBar As EFSScrollBarConstants) As Long
  376.    If (eBar = efsHorizontal) Then
  377.       SmallChange = m_lSmallChangeHorz
  378.    Else
  379.       SmallChange = m_lSmallChangeVert
  380.    End If
  381. End Property
  382. Public Property Let SmallChange(ByVal eBar As EFSScrollBarConstants, ByVal lSmallChange As Long)
  383.    If (eBar = efsHorizontal) Then
  384.       m_lSmallChangeHorz = lSmallChange
  385.    Else
  386.       m_lSmallChangeVert = lSmallChange
  387.    End If
  388. End Property
  389. Public Property Get Enabled(ByVal eBar As EFSScrollBarConstants) As Boolean
  390.    If (eBar = efsHorizontal) Then
  391.       Enabled = m_bEnabledHorz
  392.    Else
  393.       Enabled = m_bEnabledVert
  394.    End If
  395. End Property
  396. Public Property Let Enabled(ByVal eBar As EFSScrollBarConstants, ByVal bEnabled As Boolean)
  397. Dim lO As Long
  398. Dim lF As Long
  399.         
  400.    lO = eBar
  401.    If (bEnabled) Then
  402.       lF = ESB_ENABLE_BOTH
  403.    Else
  404.       lF = ESB_DISABLE_BOTH
  405.    End If
  406.    If (m_bNoFlatScrollBars) Then
  407.       EnableScrollBar m_hWnd, lO, lF
  408.    Else
  409.       FlatSB_EnableScrollBar m_hWnd, lO, lF
  410.    End If
  411.     
  412. End Property
  413. Public Property Get Min(ByVal eBar As EFSScrollBarConstants) As Long
  414. Dim tSI As SCROLLINFO
  415.     pGetSI eBar, tSI, SIF_RANGE
  416.     Min = tSI.nMin
  417. End Property
  418. Public Property Get Max(ByVal eBar As EFSScrollBarConstants) As Long
  419. Dim tSI As SCROLLINFO
  420.     pGetSI eBar, tSI, SIF_RANGE Or SIF_PAGE
  421.     Max = tSI.nMax - tSI.nPage
  422. End Property
  423. Public Property Get Value(ByVal eBar As EFSScrollBarConstants) As Long
  424. Dim tSI As SCROLLINFO
  425.     pGetSI eBar, tSI, SIF_POS
  426.     Value = tSI.nPos
  427. End Property
  428. Public Property Get LargeChange(ByVal eBar As EFSScrollBarConstants) As Long
  429. Dim tSI As SCROLLINFO
  430.     pGetSI eBar, tSI, SIF_PAGE
  431.     LargeChange = tSI.nPage
  432. End Property
  433. Public Property Let Min(ByVal eBar As EFSScrollBarConstants, ByVal iMin As Long)
  434. Dim tSI As SCROLLINFO
  435.     tSI.nMin = iMin
  436.     tSI.nMax = Max(eBar) + LargeChange(eBar)
  437.     pLetSI eBar, tSI, SIF_RANGE
  438. End Property
  439. Public Property Let Max(ByVal eBar As EFSScrollBarConstants, ByVal iMax As Long)
  440. Dim tSI As SCROLLINFO
  441.     tSI.nMax = iMax + LargeChange(eBar)
  442.     tSI.nMin = Min(eBar)
  443.     pLetSI eBar, tSI, SIF_RANGE
  444.     pRaiseEvent eBar, False
  445. End Property
  446. Public Property Let Value(ByVal eBar As EFSScrollBarConstants, ByVal iValue As Long)
  447. Dim tSI As SCROLLINFO
  448.     If (iValue <> Value(eBar)) Then
  449.         tSI.nPos = iValue
  450.         pLetSI eBar, tSI, SIF_POS
  451.         pRaiseEvent eBar, False
  452.     End If
  453. End Property
  454. Public Property Let LargeChange(ByVal eBar As EFSScrollBarConstants, ByVal iLargeChange As Long)
  455. Dim tSI As SCROLLINFO
  456. Dim lCurMax As Long
  457. Dim lCurLargeChange As Long
  458.     
  459.    pGetSI eBar, tSI, SIF_ALL
  460.    tSI.nMax = tSI.nMax - tSI.nPage + iLargeChange
  461.    tSI.nPage = iLargeChange
  462.    pLetSI eBar, tSI, SIF_PAGE Or SIF_RANGE
  463. End Property
  464. Public Property Get CanBeFlat() As Boolean
  465.    CanBeFlat = Not (m_bNoFlatScrollBars)
  466. End Property
  467. Private Sub pCreateScrollBar()
  468. Dim lR As Long
  469. Dim lStyle As Long
  470. Dim hParent As Long
  471.  
  472.    ' Just checks for flag scroll bars...
  473.    On Error Resume Next
  474.    lR = InitialiseFlatSB(m_hWnd)
  475.    If (Err.Number <> 0) Then
  476.        'Can't find DLL entry point InitializeFlatSB in COMCTL32.DLL
  477.        ' Means we have version prior to 4.71
  478.        ' We get standard scroll bars.
  479.        m_bNoFlatScrollBars = True
  480.    Else
  481.       Style = m_eStyle
  482.    End If
  483.    
  484. End Sub
  485.  
  486. Public Sub Create(ByVal hWndA As Long)
  487.    pClearUp
  488.    m_hWnd = hWndA
  489.    pCreateScrollBar
  490.    pAttachMessages
  491. End Sub
  492.  
  493. Private Sub pClearUp()
  494.    If m_hWnd <> 0 Then
  495.       On Error Resume Next
  496.       ' Stop flat scroll bar if we have it:
  497.       If Not (m_bNoFlatScrollBars) Then
  498.          UninitializeFlatSB m_hWnd
  499.       End If
  500.     
  501.       On Error GoTo 0
  502.       ' Remove subclass:
  503.       DetachMessage Me, m_hWnd, WM_HSCROLL
  504.       DetachMessage Me, m_hWnd, WM_VSCROLL
  505.       DetachMessage Me, m_hWnd, WM_MOUSEWHEEL
  506.       DetachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
  507.       DetachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
  508.       DetachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
  509.    End If
  510.    m_hWnd = 0
  511.    m_bInitialised = False
  512. End Sub
  513. Private Sub pAttachMessages()
  514.    If (m_hWnd <> 0) Then
  515.       AttachMessage Me, m_hWnd, WM_HSCROLL
  516.       AttachMessage Me, m_hWnd, WM_VSCROLL
  517.       AttachMessage Me, m_hWnd, WM_MOUSEWHEEL
  518.       AttachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
  519.       AttachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
  520.       AttachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
  521.       SystemParametersInfo SPI_GETWHEELSCROLLLINES, _
  522.             0, m_lWheelScrollLines, 0
  523.       If (m_lWheelScrollLines <= 0) Then
  524.          m_lWheelScrollLines = 3
  525.       End If
  526.       m_bInitialised = True
  527.    End If
  528. End Sub
  529.  
  530. Private Sub Class_Initialize()
  531.    m_lSmallChangeHorz = 1
  532.    m_lSmallChangeVert = 1
  533.    m_eStyle = efsRegular
  534.    m_eOrientation = efsoBoth
  535. End Sub
  536.  
  537. Private Sub Class_Terminate()
  538.    pClearUp
  539. End Sub
  540.  
  541. Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
  542.    '
  543. End Property
  544.  
  545. Private Property Get ISubclass_MsgResponse() As EMsgResponse
  546.    ISubclass_MsgResponse = emrPostProcess
  547. End Property
  548.  
  549. Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  550. Dim lScrollCode As Long
  551. Dim tSI As SCROLLINFO
  552. Dim lV As Long, lSC As Long
  553. Dim eBar As EFSScrollBarConstants
  554. Dim zDelta As Long
  555. Dim lDelta As Long
  556. Dim wMKeyFlags As Long
  557.  
  558.    Select Case iMsg
  559.    Case WM_MOUSEWHEEL
  560.       ' Low-word of wParam indicates whether virtual keys
  561.       ' are down
  562.       wMKeyFlags = wParam And &HFFFF&
  563.       ' High order word is the distance the wheel has been rotated,
  564.       ' in multiples of WHEEL_DELTA:
  565.       If (wParam And &H8000000) Then
  566.          ' Towards the user:
  567.          zDelta = &H8000& - (wParam And &H7FFF0000) \ &H10000
  568.       Else
  569.          ' Away from the user:
  570.          zDelta = -((wParam And &H7FFF0000) \ &H10000)
  571.       End If
  572.       lDelta = (zDelta \ WHEEL_DELTA) * SmallChange(efsVertical) * m_lWheelScrollLines
  573.       eBar = efsVertical
  574.       RaiseEvent MouseWheel(eBar, lDelta)
  575.       If Not (lDelta = 0) Then
  576.          Value(eBar) = Value(eBar) + lDelta
  577.          ISubclass_WindowProc = 1
  578.       End If
  579.    
  580.    Case WM_VSCROLL, WM_HSCROLL
  581.       If (iMsg = WM_HSCROLL) Then
  582.          eBar = efsHorizontal
  583.       Else
  584.          eBar = efsVertical
  585.       End If
  586.       lScrollCode = (wParam And &HFFFF&)
  587.       Select Case lScrollCode
  588.       Case SB_THUMBTRACK
  589.          ' Is vertical/horizontal?
  590.          pGetSI eBar, tSI, SIF_TRACKPOS
  591.          Value(eBar) = tSI.nTrackPos
  592.          pRaiseEvent eBar, True
  593.          
  594.       Case SB_LEFT, SB_TOP
  595.          Value(eBar) = Min(eBar)
  596.          pRaiseEvent eBar, False
  597.          
  598.       Case SB_RIGHT, SB_BOTTOM
  599.          Value(eBar) = Max(eBar)
  600.          pRaiseEvent eBar, False
  601.           
  602.       Case SB_LINELEFT, SB_LINEUP
  603.          'Debug.Print "Line"
  604.          lV = Value(eBar)
  605.          If (eBar = efsHorizontal) Then
  606.             lSC = m_lSmallChangeHorz
  607.          Else
  608.             lSC = m_lSmallChangeVert
  609.          End If
  610.          If (lV - lSC < Min(eBar)) Then
  611.             Value(eBar) = Min(eBar)
  612.          Else
  613.             Value(eBar) = lV - lSC
  614.          End If
  615.          pRaiseEvent eBar, False
  616.          
  617.       Case SB_LINERIGHT, SB_LINEDOWN
  618.           'Debug.Print "Line"
  619.          lV = Value(eBar)
  620.          If (eBar = efsHorizontal) Then
  621.             lSC = m_lSmallChangeHorz
  622.          Else
  623.             lSC = m_lSmallChangeVert
  624.          End If
  625.          If (lV + lSC > Max(eBar)) Then
  626.             Value(eBar) = Max(eBar)
  627.          Else
  628.             Value(eBar) = lV + lSC
  629.          End If
  630.          pRaiseEvent eBar, False
  631.           
  632.       Case SB_PAGELEFT, SB_PAGEUP
  633.          Value(eBar) = Value(eBar) - LargeChange(eBar)
  634.          pRaiseEvent eBar, False
  635.          
  636.       Case SB_PAGERIGHT, SB_PAGEDOWN
  637.          Value(eBar) = Value(eBar) + LargeChange(eBar)
  638.          pRaiseEvent eBar, False
  639.          
  640.       Case SB_ENDSCROLL
  641.          pRaiseEvent eBar, False
  642.          
  643.       End Select
  644.       
  645.    Case WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN
  646.       Dim eBtn As MouseButtonConstants
  647.       eBtn = IIf(iMsg = WM_NCLBUTTONDOWN, vbLeftButton, vbRightButton)
  648.       If wParam = HTVSCROLL Then
  649.          RaiseEvent ScrollClick(efsHorizontal, eBtn)
  650.       ElseIf wParam = HTHSCROLL Then
  651.          RaiseEvent ScrollClick(efsVertical, eBtn)
  652.       End If
  653.       
  654.          
  655.    End Select
  656.  
  657. End Function
  658.  
  659. Private Function pRaiseEvent(ByVal eBar As EFSScrollBarConstants, ByVal bScroll As Boolean)
  660. Static s_lLastValue(0 To 1) As Long
  661.    If (Value(eBar) <> s_lLastValue(eBar)) Then
  662.       If (bScroll) Then
  663.          RaiseEvent Scroll(eBar)
  664.       Else
  665.          RaiseEvent Change(eBar)
  666.       End If
  667.       s_lLastValue(eBar) = Value(eBar)
  668.    End If
  669.    
  670. End Function
  671.  
  672.  
  673.  
  674.  
  675.  
  676.  
  677.  
  678.