home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Carles_P_V2083999202007.psc / ucScrollbar.ctl < prev   
Text File  |  2007-09-20  |  67KB  |  1,498 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ucScrollbar 
  3.    BackColor       =   &H80000005&
  4.    CanGetFocus     =   0   'False
  5.    ClientHeight    =   2655
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   240
  9.    ClipControls    =   0   'False
  10.    FillStyle       =   0  'Solid
  11.    FontTransparent =   0   'False
  12.    ForeColor       =   &H8000000F&
  13.    ScaleHeight     =   177
  14.    ScaleMode       =   3  'Pixel
  15.    ScaleWidth      =   16
  16.    ToolboxBitmap   =   "ucScrollbar.ctx":0000
  17. End
  18. Attribute VB_Name = "ucScrollbar"
  19. Attribute VB_GlobalNameSpace = False
  20. Attribute VB_Creatable = True
  21. Attribute VB_PredeclaredId = False
  22. Attribute VB_Exposed = False
  23. '========================================================================================
  24. ' User control:  ucScrollbar.ctl
  25. ' Author:        Carles P.V. - 2005 (*)
  26. ' Dependencies:  None
  27. ' Last revision: 12.20.2005
  28. ' Version:       1.0.5 (Jason James Newland 2007)
  29. '----------------------------------------------------------------------------------------
  30. '
  31. ' (*) 1. Self-Subclassing UserControl template (IDE safe) by Paul Caton:
  32. '
  33. '        Self-subclassing Controls/Forms - NO dependencies
  34. '        http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=54117&lngWId=1
  35. '
  36. '     2. pvCheckEnvironment() and pvIsLuna() routines by Paul Caton
  37. '
  38. '     3. Flat button fxs code extracted from (see pvDrawFlatButton() routine):
  39. '        Special flat Cool Scrollbars version 1.2 by James Brown
  40. '        http://www.catch22.net/tuts/coolscroll.asp
  41. '----------------------------------------------------------------------------------------
  42. '
  43. ' History:
  44. '
  45. '   * 1.0.0: - First release.
  46. '   * 1.0.1: - Flat style *properly* painted:
  47. '              * Hot thumb appearance = Pressed thumb appearance.
  48. '              * Pressed/hot buttons using correct system colors.
  49. '              Is there a default? For example, ListView with flat-scrollbars flag set,
  50. '              preserves pressed buttons with 1-pixel edge using 'shadow' color and
  51. '              their background is filled using color black instead of 'dark shadow'.
  52. '   * 1.0.2: - Added Refresh method: only for custom-draw purposes.
  53. '   * 1.0.3: - Fixed control on m_bHasTrack and m_bHasNullTrack flags.
  54. '   * 1.0.4: - Fixed thumb rendering (classic style). DrawFrameControl->DrawEdge.
  55. '   * 1.0.5: - Added theme support for Vista in theme mode style (JJN)
  56. '----------------------------------------------------------------------------------------
  57. '
  58. ' Notes:
  59. '
  60. '   * Restriction: Max >= Min
  61. '   * Restriction: TabStop not supported
  62. '----------------------------------------------------------------------------------------
  63. '
  64. ' Known issues:
  65. '========================================================================================
  66.  
  67. Option Explicit
  68.  
  69. Private Const VERSION_INFO As String = "1.0.5"
  70. '========================================================================================
  71. ' Subclasser declarations
  72. '========================================================================================
  73. Private Enum eMsgWhen
  74.     [MSG_AFTER] = 1                                                           'Message calls back after the original (previous) WndProc
  75.     [MSG_BEFORE] = 2                                                          'Message calls back before the original (previous) WndProc
  76.     [MSG_BEFORE_AND_AFTER] = MSG_AFTER Or MSG_BEFORE                          'Message calls back before and after the original (previous) WndProc
  77. End Enum
  78.  
  79. Private Type tSubData                                                         'Subclass data type
  80.     hwnd                   As Long                                            'Handle of the window being subclassed
  81.     nAddrSub               As Long                                            'The address of our new WndProc (allocated memory).
  82.     nAddrOrig              As Long                                            'The address of the pre-existing WndProc
  83.     nMsgCntA               As Long                                            'Msg after table entry count
  84.     nMsgCntB               As Long                                            'Msg before table entry count
  85.     aMsgTblA()             As Long                                            'Msg after table array
  86.     aMsgTblB()             As Long                                            'Msg Before table array
  87. End Type
  88.  
  89. Private sc_aSubData()      As tSubData                                        'Subclass data array
  90. Private Const ALL_MESSAGES As Long = -1                                       'All messages added or deleted
  91. Private Const GMEM_FIXED   As Long = 0                                        'Fixed memory GlobalAlloc flag
  92. Private Const GWL_WNDPROC  As Long = -4                                       'Get/SetWindow offset to the WndProc procedure address
  93. Private Const PATCH_04     As Long = 88                                       'Table B (before) address patch offset
  94. Private Const PATCH_05     As Long = 93                                       'Table B (before) entry count patch offset
  95. Private Const PATCH_08     As Long = 132                                      'Table A (after) address patch offset
  96. Private Const PATCH_09     As Long = 137                                      'Table A (after) entry count patch offset
  97.  
  98. Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
  99. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
  100. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
  101. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  102. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  103. Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  104.  
  105. '========================================================================================
  106. ' UserControl API declarations
  107. '========================================================================================
  108. Private Const SM_CXVSCROLL  As Long = 2
  109. Private Const SM_CYHSCROLL  As Long = 3
  110. Private Const SM_CYVSCROLL  As Long = 20
  111. Private Const SM_CXHSCROLL  As Long = 21
  112. Private Const SM_SWAPBUTTON As Long = 23
  113.  
  114. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  115.  
  116. Private Const SPI_GETKEYBOARDDELAY As Long = 22
  117. Private Const SPI_GETKEYBOARDPREF  As Long = 68
  118.  
  119. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
  120.  
  121. Private Type POINTAPI
  122.     x As Long
  123.     y As Long
  124. End Type
  125.  
  126. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  127. Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
  128.  
  129. Private Type RECT
  130.     x1 As Long
  131.     y1 As Long
  132.     x2 As Long
  133.     y2 As Long
  134. End Type
  135.  
  136. Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
  137. Private Declare Function SetRectEmpty Lib "user32" (lpRect As RECT) As Long
  138. Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
  139. Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  140. Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  141. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  142. Private Declare Function InvertRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
  143. Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
  144. Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  145.  
  146. Private Const DFC_SCROLL          As Long = 3
  147. Private Const DFCS_SCROLLUP       As Long = &H0
  148. Private Const DFCS_SCROLLDOWN     As Long = &H1
  149. Private Const DFCS_SCROLLLEFT     As Long = &H2
  150. Private Const DFCS_SCROLLRIGHT    As Long = &H3
  151. Private Const DFCS_INACTIVE       As Long = &H100
  152. Private Const DFCS_PUSHED         As Long = &H200
  153. Private Const DFCS_FLAT           As Long = &H4000
  154. Private Const DFCS_MONO           As Long = &H8000
  155.  
  156. Private Declare Function DrawFrameControl Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
  157.  
  158. Private Const BDR_RAISED As Long = &H5
  159. Private Const BF_RECT    As Long = &HF
  160.  
  161. Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
  162.  
  163. Private Const COLOR_BTNFACE     As Long = 15
  164. Private Const COLOR_3DSHADOW    As Long = 16
  165. Private Const COLOR_BTNTEXT     As Long = 18
  166. Private Const COLOR_3DHIGHLIGHT As Long = 20
  167. Private Const COLOR_3DDKSHADOW  As Long = 21
  168.  
  169. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  170. Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
  171.  
  172. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  173. Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  174.  
  175. Private Const WHITE_BRUSH As Long = 0
  176. Private Const BLACK_BRUSH As Long = 4
  177.  
  178. Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
  179.     
  180. Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
  181.  
  182. Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
  183.  
  184. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  185. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  186. Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Integer) As Long
  187. Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
  188. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  189. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  190. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  191. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  192.  
  193. Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  194. Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
  195.  
  196. Private Type PAINTSTRUCT
  197.     hdc             As Long
  198.     fErase          As Long
  199.     rcPaint         As RECT
  200.     fRestore        As Long
  201.     fIncUpdate      As Long
  202.     rgbReserved(32) As Byte
  203. End Type
  204. Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
  205. Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
  206. Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
  207.  
  208. Private Const WM_SIZE           As Long = &H5
  209. Private Const WM_PAINT          As Long = &HF
  210. Private Const WM_SYSCOLORCHANGE As Long = &H15
  211. Private Const WM_CANCELMODE     As Long = &H1F
  212. Private Const WM_TIMER          As Long = &H113
  213. Private Const WM_MOUSEMOVE      As Long = &H200
  214. Private Const WM_LBUTTONDOWN    As Long = &H201
  215. Private Const WM_LBUTTONUP      As Long = &H202
  216. Private Const WM_LBUTTONDBLCLK  As Long = &H203
  217. Private Const WM_THEMECHANGED   As Long = &H31A
  218.  
  219. Private Const MK_LBUTTON        As Long = &H1
  220.  
  221. Private Type OSVERSIONINFO
  222.     dwOSVersionInfoSize As Long
  223.     dwMajorVersion      As Long
  224.     dwMinorVersion      As Long
  225.     dwBuildNumber       As Long
  226.     dwPlatformId        As Long
  227.     szCSDVersion        As String * 128
  228. End Type
  229.  
  230. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
  231. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  232. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
  233.  
  234. Private Declare Function GetCurrentThemeName Lib "uxtheme" (ByVal pszThemeFileName As Long, ByVal cchMaxNameChars As Long, ByVal pszColorBuff As Long, ByVal cchMaxColorChars As Long, ByVal pszSizeBuff As Long, ByVal cchMaxSizeChars As Long) As Long
  235. Private Declare Function GetThemeDocumentationProperty Lib "uxtheme" (ByVal pszThemeName As Long, ByVal pszPropertyName As Long, ByVal pszValueBuff As Long, ByVal cchMaxValChars As Long) As Long
  236. Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
  237. Private Declare Function CloseThemeData Lib "uxtheme" (ByVal hTheme As Long) As Long
  238. Private Declare Function DrawThemeBackground Lib "uxtheme" (ByVal hTheme As Long, ByVal lhDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, pClipRect As RECT) As Long
  239.  
  240. ' Class name
  241. Private Const SB_THEME As String = "Scrollbar"
  242.  
  243. ' [UxThemeSCROLLBARParts]
  244. Private Const SBP_ARROWBTN = 1
  245. Private Const SBP_THUMBBTNHORZ = 2
  246. Private Const SBP_THUMBBTNVERT = 3
  247. Private Const SBP_LOWERTRACKHORZ = 4
  248. Private Const SBP_UPPERTRACKHORZ = 5
  249. Private Const SBP_LOWERTRACKVERT = 6
  250. Private Const SBP_UPPERTRACKVERT = 7
  251. Private Const SBP_GRIPPERHORZ = 8
  252. Private Const SBP_GRIPPERVERT = 9
  253. Private Const SBP_SIZEBOX = 10
  254.  
  255. ' [UxThemeARROWBTNStates]
  256. Private Const ABS_UPNORMAL = 1
  257. Private Const ABS_UPHOT = 2
  258. Private Const ABS_UPPRESSED = 3
  259. Private Const ABS_UPDISABLED = 4
  260. Private Const ABS_DOWNNORMAL = 5
  261. Private Const ABS_DOWNHOT = 6
  262. Private Const ABS_DOWNPRESSED = 7
  263. Private Const ABS_DOWNDISABLED = 8
  264. Private Const ABS_LEFTNORMAL = 9
  265. Private Const ABS_LEFTHOT = 10
  266. Private Const ABS_LEFTPRESSED = 11
  267. Private Const ABS_LEFTDISABLED = 12
  268. Private Const ABS_RIGHTNORMAL = 13
  269. Private Const ABS_RIGHTHOT = 14
  270. Private Const ABS_RIGHTPRESSED = 15
  271. Private Const ABS_RIGHTDISABLED = 16
  272.  
  273. ' [UxThemeHorzScrollStates]
  274. Private Const HSS_NORMAL = 1
  275. Private Const HSS_HOT = 2
  276. Private Const HSS_PUSHED = 3
  277. Private Const HSS_DISABLED = 4
  278.  
  279. ' [UxThemeHorzThumbStates]
  280. Private Const HTS_NORMAL = 1
  281. Private Const HTS_HOT = 2
  282. Private Const HTS_PUSHED = 3
  283. Private Const HTS_DISABLED = 4
  284.  
  285. ' [UxThemeVertScrollStates]
  286. Private Const VSS_NORMAL = 1
  287. Private Const VSS_HOT = 2
  288. Private Const VSS_PUSHED = 3
  289. Private Const VSS_DISABLED = 4
  290.  
  291. ' [UxThemeVertThumbStates]
  292. Private Const VTS_NORMAL = 1
  293. Private Const VTS_HOT = 2
  294. Private Const VTS_PUSHED = 3
  295. Private Const VTS_DISABLED = 4
  296.  
  297. '========================================================================================
  298. ' UserControl enums., variables and constants
  299. '========================================================================================
  300. '-- Public enums.:
  301. Public Enum sbOrientationCts
  302.     [oVertical] = 0
  303.     [oHorizontal] = 1
  304. End Enum
  305.  
  306. Public Enum sbStyleCts
  307.     [sClassic] = 0
  308.     [sFlat] = 1
  309.     [sThemed] = 2
  310.     [sCustomDraw] = 3
  311. End Enum
  312.  
  313. Public Enum sbOnPaintPartCts
  314.     [ppTLButton] = 0
  315.     [ppBRButton] = 1
  316.     [ppTLTrack] = 2
  317.     [ppBRTrack] = 3
  318.     [ppNullTrack] = 4
  319.     [ppThumb] = 5
  320. End Enum
  321.  
  322. Public Enum sbOnPaintPartStateCts
  323.     [ppsNormal] = 0
  324.     [ppsPressed] = 1
  325.     [ppsHot] = 2
  326.     [ppsDisabled] = 3
  327. End Enum
  328.  
  329. '-- Private enums.:
  330. Private Enum eFlatButtonStateCts
  331.     [fbsNormal] = 0
  332.     [fbsSelected] = 1
  333.     [fbsHot] = 2
  334. End Enum
  335.  
  336. '-- Private constants:
  337. Private Const HT_NOTHING          As Long = 0
  338. Private Const HT_TLBUTTON         As Long = 1
  339. Private Const HT_BRBUTTON         As Long = 2
  340. Private Const HT_TLTRACK          As Long = 3
  341. Private Const HT_BRTRACK          As Long = 4
  342. Private Const HT_THUMB            As Long = 5
  343.  
  344. Private Const TIMERID_CHANGE1     As Long = 1
  345. Private Const TIMERID_CHANGE2     As Long = 2
  346. Private Const TIMERID_HOT         As Long = 3
  347.  
  348. Private Const CHANGEDELAY_MIN     As Long = 0
  349. Private Const CHANGEFREQUENCY_MIN As Long = 25
  350. Private Const TIMERDT_HOT         As Long = 25
  351.  
  352. Private Const THUMBSIZE_MIN       As Long = 8
  353. Private Const GRIPPERSIZE_MIN     As Long = 16
  354.  
  355. '-- Private variables:
  356. Private m_bHasTrack               As Boolean
  357. Private m_bHasNullTrack           As Boolean
  358. Private m_uRctNullTrack           As RECT
  359.  
  360. Private m_uRctTLButton            As RECT
  361. Private m_uRctBRButton            As RECT
  362. Private m_uRctTLTrack             As RECT
  363. Private m_uRctBRTrack             As RECT
  364. Private m_uRctThumb               As RECT
  365. Private m_lThumbOffset            As Long
  366. Private m_uRctDrag                As RECT
  367.  
  368. Private m_bTLButtonPressed        As Boolean
  369. Private m_bBRButtonPressed        As Boolean
  370. Private m_bTLTrackPressed         As Boolean
  371. Private m_bBRTrackPressed         As Boolean
  372. Private m_bThumbPressed           As Boolean
  373.  
  374. Private m_bTLButtonHot            As Boolean
  375. Private m_bBRButtonHot            As Boolean
  376. Private m_bThumbHot               As Boolean
  377.  
  378. Private m_lAbsRange               As Long
  379. Private m_lThumbPos               As Long
  380. Private m_lThumbSize              As Long
  381. Private m_eHitTest                As Long
  382. Private m_eHitTestHot             As Long
  383. Private m_x                       As Long
  384. Private m_y                       As Long
  385. Private m_lValueStartDrag         As Long
  386.  
  387. Private m_hPatternBrush           As Long
  388.  
  389. '-- Property variables:
  390. Private m_lChangeDelay            As Long
  391. Private m_lChangeFrequency        As Long
  392. Private m_lMax                    As Long
  393. Private m_lMin                    As Long
  394. Private m_lValue                  As Long
  395. Private m_lSmallChange            As Long
  396. Private m_lLargeChange            As Long
  397. Private m_eOrientation            As sbOrientationCts
  398. Private m_eStyle                  As sbStyleCts
  399. Private m_bShowButtons            As Boolean
  400.  
  401. Private m_bIsXP                   As Boolean ' RO
  402. Private m_bIsLuna                 As Boolean ' RO
  403.  
  404. '-- Default property values:
  405. Private Const ENABLED_DEF         As Boolean = True
  406. Private Const MIN_DEF             As Long = 0
  407. Private Const MAX_DEF             As Long = 100
  408. Private Const VALUE_DEF           As Long = MIN_DEF
  409. Private Const SMALLCHANGE_DEF     As Long = 1
  410. Private Const LARGECHANGE_DEF     As Long = 10
  411. Private Const CHANGEDELAY_DEF     As Long = 500
  412. Private Const CHANGEFREQUENCY_DEF As Long = 50
  413. Private Const ORIENTATION_DEF     As Long = [oVertical]
  414. Private Const STYLE_DEF           As Long = [sClassic]
  415. Private Const SHOWBUTTONS_DEF     As Boolean = True
  416.  
  417. '-- Events:
  418. Public Event Change()
  419. Public Event Scroll()
  420. Public Event ThemeChanged()
  421. Public Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  422. Public Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  423. Public Event OnPaint(ByVal lhDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal ePart As sbOnPaintPartCts, ByVal eState As sbOnPaintPartStateCts)
  424.  
  425. '========================================================================================
  426. ' UserControl initialization/termination
  427. '========================================================================================
  428. Private Sub UserControl_Initialize()
  429.     Call pvCreatePatternBrush
  430. End Sub
  431.  
  432. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  433.     RaiseEvent MouseDown(Button, Shift, x, y)
  434. End Sub
  435.  
  436. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  437.     RaiseEvent MouseUp(Button, Shift, x, y)
  438. End Sub
  439.  
  440. Private Sub UserControl_Terminate()
  441.     On Error GoTo Catch
  442.     '-- Stop subclassing
  443.     Call Subclass_StopAll
  444. Catch:
  445.     On Error GoTo 0
  446.     '-- In any case...
  447.     Call pvKillTimer(TIMERID_HOT)
  448.     Call pvKillTimer(TIMERID_CHANGE1)
  449.     Call pvKillTimer(TIMERID_CHANGE2)
  450.     '-- Clean up
  451.     Call DeleteObject(m_hPatternBrush)
  452. End Sub
  453.  
  454. '========================================================================================
  455. ' Only in design-mode
  456. '========================================================================================
  457. Private Sub UserControl_Resize()
  458.     On Error Resume Next
  459.     If (Ambient.UserMode = False) Then
  460.         Call pvOnSize
  461.     End If
  462. End Sub
  463.  
  464. Private Sub UserControl_Paint()
  465.     If (Ambient.UserMode = False) Then
  466.         Call pvOnPaint(UserControl.hdc)
  467.     End If
  468. End Sub
  469.  
  470. '========================================================================================
  471. ' UserControl subclass procedure
  472. '========================================================================================
  473. Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lHWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)
  474. Attribute zSubclass_Proc.VB_MemberFlags = "40"
  475.     Dim uPS As PAINTSTRUCT
  476.     '
  477.     Select Case lHWnd
  478.         Case UserControl.hwnd
  479.             Select Case uMsg
  480.                 Case WM_PAINT
  481.                     Call BeginPaint(lHWnd, uPS)
  482.                     Call pvOnPaint(uPS.hdc)
  483.                     Call EndPaint(lHWnd, uPS)
  484.                     bHandled = True: lReturn = 0
  485.                 Case WM_SIZE
  486.                     Call pvOnSize
  487.                     bHandled = True: lReturn = 0
  488.                 Case WM_LBUTTONDOWN
  489.                     Call pvOnMouseDown(wParam, lParam)
  490.                 Case WM_MOUSEMOVE
  491.                     Call pvOnMouseMove(wParam, lParam)
  492.                 Case WM_LBUTTONUP, WM_CANCELMODE
  493.                     Call pvOnMouseUp
  494.                 Case WM_LBUTTONDBLCLK
  495.                     Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
  496.                 Case WM_TIMER
  497.                     Call pvOnTimer(wParam)
  498.                 Case WM_SYSCOLORCHANGE
  499.                     Call pvOnSysColorChange
  500.                 Case WM_THEMECHANGED
  501.                     Call pvOnThemeChanged
  502.             End Select
  503.     End Select
  504. End Sub
  505.  
  506. '========================================================================================
  507. ' Methods
  508. '========================================================================================
  509. Public Sub Refresh()
  510.     '-- Force a complete paint
  511.     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  512. End Sub
  513.  
  514. '========================================================================================
  515. ' Messages response
  516. '========================================================================================
  517. Private Sub pvOnSize()
  518.     Call pvSizeButtons
  519.     m_lThumbSize = pvGetThumbSize()
  520.     m_lThumbPos = pvGetThumbPos()
  521.     Call pvSizeTrack
  522.     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  523. End Sub
  524.  
  525. Private Sub pvOnPaint(ByVal lhDC As Long)
  526.     Dim lfHorz As Long
  527.     '
  528.     lfHorz = -CLng(m_eOrientation = [oHorizontal])
  529.     Select Case True
  530.         Case m_eStyle = [sClassic] Or (m_eStyle = [sThemed] And m_bIsLuna = False)
  531.             If (UserControl.Enabled) Then
  532.                 '-- Buttons
  533.                 If (m_bTLButtonPressed) Then
  534.                     Call DrawFrameControl(lhDC, m_uRctTLButton, DFC_SCROLL, DFCS_SCROLLUP + (2 * lfHorz) Or DFCS_FLAT Or DFCS_PUSHED)
  535.                 Else
  536.                     Call DrawFrameControl(lhDC, m_uRctTLButton, DFC_SCROLL, DFCS_SCROLLUP + (2 * lfHorz))
  537.                 End If
  538.                 If (m_bBRButtonPressed) Then
  539.                     Call DrawFrameControl(lhDC, m_uRctBRButton, DFC_SCROLL, DFCS_SCROLLDOWN + (2 * lfHorz) Or DFCS_FLAT Or DFCS_PUSHED)
  540.                 Else
  541.                     Call DrawFrameControl(lhDC, m_uRctBRButton, DFC_SCROLL, DFCS_SCROLLDOWN + (2 * lfHorz))
  542.                 End If
  543.                 '-- Track + thumb
  544.                 If (m_bHasTrack) Then
  545.                     '-- Top-Left track part
  546.                     If (m_bTLTrackPressed) Then
  547.                         Call FillRect(lhDC, m_uRctTLTrack, GetStockObject(BLACK_BRUSH))
  548.                     Else
  549.                         Call FillRect(lhDC, m_uRctTLTrack, m_hPatternBrush)
  550.                     End If
  551.                     '-- Right-Bottom track part
  552.                     If (m_bBRTrackPressed) Then
  553.                         Call FillRect(lhDC, m_uRctBRTrack, GetStockObject(BLACK_BRUSH))
  554.                     Else
  555.                         Call FillRect(lhDC, m_uRctBRTrack, m_hPatternBrush)
  556.                     End If
  557.                     '-- Thumb
  558.                     Call FillRect(lhDC, m_uRctThumb, GetSysColorBrush(COLOR_BTNFACE))
  559.                     Call DrawEdge(lhDC, m_uRctThumb, BDR_RAISED, BF_RECT)
  560.                 End If
  561.                 If (m_bHasNullTrack) Then
  562.                     Call FillRect(lhDC, m_uRctNullTrack, m_hPatternBrush)
  563.                 End If
  564.             Else
  565.                 '-- Draw all disabled
  566.                 Call DrawFrameControl(lhDC, m_uRctTLButton, DFC_SCROLL, DFCS_SCROLLUP + (2 * lfHorz) Or DFCS_INACTIVE)
  567.                 Call DrawFrameControl(lhDC, m_uRctBRButton, DFC_SCROLL, DFCS_SCROLLDOWN + (2 * lfHorz) Or DFCS_INACTIVE)
  568.                 If (m_bHasTrack) Then
  569.                     Call FillRect(lhDC, m_uRctTLTrack, m_hPatternBrush)
  570.                     Call FillRect(lhDC, m_uRctBRTrack, m_hPatternBrush)
  571.                     Call DrawFrameControl(lhDC, m_uRctThumb, 0, 0)
  572.                 End If
  573.                 If (m_bHasNullTrack) Then
  574.                     Call FillRect(lhDC, m_uRctNullTrack, m_hPatternBrush)
  575.                 End If
  576.             End If
  577.         Case m_eStyle = [sFlat]
  578.             If (UserControl.Enabled) Then
  579.                 '-- Buttons
  580.                 If (m_bTLButtonHot) Then
  581.                     Call pvDrawFlatButton(lhDC, m_uRctTLButton, DFCS_SCROLLUP + (2 * lfHorz), [fbsHot])
  582.                 Else
  583.                     If (m_bTLButtonPressed) Then
  584.                         Call pvDrawFlatButton(lhDC, m_uRctTLButton, DFCS_SCROLLUP + (2 * lfHorz), [fbsSelected])
  585.                       Else
  586.                         Call pvDrawFlatButton(lhDC, m_uRctTLButton, DFCS_SCROLLUP + (2 * lfHorz), [fbsNormal])
  587.                     End If
  588.                 End If
  589.                 If (m_bBRButtonHot) Then
  590.                     Call pvDrawFlatButton(lhDC, m_uRctBRButton, DFCS_SCROLLDOWN + (2 * lfHorz), [fbsHot])
  591.                 Else
  592.                     If (m_bBRButtonPressed) Then
  593.                         Call pvDrawFlatButton(lhDC, m_uRctBRButton, DFCS_SCROLLDOWN + (2 * lfHorz), [fbsSelected])
  594.                     Else
  595.                         Call pvDrawFlatButton(lhDC, m_uRctBRButton, DFCS_SCROLLDOWN + (2 * lfHorz), [fbsNormal])
  596.                     End If
  597.                 End If
  598.                 '-- Track + thumb
  599.                 If (m_bHasTrack) Then
  600.                     '-- Top-Left track part
  601.                     If (m_bTLTrackPressed) Then
  602.                         Call FillRect(lhDC, m_uRctTLTrack, GetStockObject(BLACK_BRUSH))
  603.                     Else
  604.                         Call FillRect(lhDC, m_uRctTLTrack, m_hPatternBrush)
  605.                     End If
  606.                     '-- Right-Bottom track part
  607.                     If (m_bBRTrackPressed) Then
  608.                         Call FillRect(lhDC, m_uRctBRTrack, GetStockObject(BLACK_BRUSH))
  609.                     Else
  610.                         Call FillRect(lhDC, m_uRctBRTrack, m_hPatternBrush)
  611.                     End If
  612.                     '-- Thumb
  613.                     If (m_bThumbHot) Then
  614.                         Call FillRect(lhDC, m_uRctThumb, GetSysColorBrush(COLOR_3DSHADOW))
  615.                     Else
  616.                         If (m_bThumbPressed) Then
  617.                             Call FillRect(lhDC, m_uRctThumb, GetSysColorBrush(COLOR_3DSHADOW))
  618.                           Else
  619.                             Call DrawFrameControl(lhDC, m_uRctThumb, 0, DFCS_FLAT)
  620.                         End If
  621.                     End If
  622.                 End If
  623.                 If (m_bHasNullTrack) Then
  624.                     Call FillRect(lhDC, m_uRctNullTrack, m_hPatternBrush)
  625.                 End If
  626.             Else
  627.                 '-- Draw all disabled
  628.                 Call DrawFrameControl(lhDC, m_uRctTLButton, DFC_SCROLL, DFCS_SCROLLUP + (2 * lfHorz) Or DFCS_FLAT Or DFCS_INACTIVE)
  629.                 Call DrawFrameControl(lhDC, m_uRctBRButton, DFC_SCROLL, DFCS_SCROLLDOWN + (2 * lfHorz) Or DFCS_FLAT Or DFCS_INACTIVE)
  630.                 If (m_bHasTrack) Then
  631.                     Call FillRect(lhDC, m_uRctTLTrack, m_hPatternBrush)
  632.                     Call FillRect(lhDC, m_uRctBRTrack, m_hPatternBrush)
  633.                     Call DrawFrameControl(lhDC, m_uRctThumb, 0, DFCS_FLAT)
  634.                 End If
  635.                 If (m_bHasNullTrack) Then
  636.                     Call FillRect(lhDC, m_uRctNullTrack, m_hPatternBrush)
  637.                 End If
  638.             End If
  639.         Case m_eStyle = [sThemed]
  640.             If (UserControl.Enabled) Then
  641.                 '-- Buttons
  642.                 If (m_bTLButtonHot) Then
  643.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_UPHOT + (8 * lfHorz), m_uRctTLButton)
  644.                 Else
  645.                     If (m_bTLButtonPressed) Then
  646.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_UPPRESSED + (8 * lfHorz), m_uRctTLButton)
  647.                     Else
  648.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_UPNORMAL + (8 * lfHorz), m_uRctTLButton)
  649.                     End If
  650.                 End If
  651.                 If (m_bBRButtonHot) Then
  652.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_DOWNHOT + (8 * lfHorz), m_uRctBRButton)
  653.                 Else
  654.                     If (m_bBRButtonPressed) Then
  655.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_DOWNPRESSED + (8 * lfHorz), m_uRctBRButton)
  656.                     Else
  657.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_DOWNNORMAL + (8 * lfHorz), m_uRctBRButton)
  658.                     End If
  659.                 End If
  660.                 '-- Track + thumb
  661.                 If (m_bHasTrack) Then
  662.                     '-- Top-Left track part
  663.                     If (m_bTLTrackPressed) Then
  664.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_UPPERTRACKVERT - (2 * lfHorz), HSS_PUSHED, m_uRctTLTrack)
  665.                     Else
  666.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_UPPERTRACKVERT - (2 * lfHorz), HSS_NORMAL, m_uRctTLTrack)
  667.                     End If
  668.                     '-- Right-Bottom track part
  669.                     If (m_bBRTrackPressed) Then
  670.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_LOWERTRACKVERT - (2 * lfHorz), HSS_PUSHED, m_uRctBRTrack)
  671.                     Else
  672.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_LOWERTRACKVERT - (2 * lfHorz), HSS_NORMAL, m_uRctBRTrack)
  673.                     End If
  674.                     '-- Thumb
  675.                     If (m_bThumbHot) Then
  676.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_THUMBBTNVERT - (lfHorz), VSS_HOT, m_uRctThumb)
  677.                         If (m_lThumbSize >= GRIPPERSIZE_MIN) Then
  678.                             Call pvDrawThemePart(lhDC, SB_THEME, SBP_GRIPPERVERT - (lfHorz), VSS_HOT, m_uRctThumb)
  679.                         End If
  680.                     Else
  681.                         If (m_bThumbPressed) Then
  682.                             Call pvDrawThemePart(lhDC, SB_THEME, SBP_THUMBBTNVERT - (lfHorz), VSS_PUSHED, m_uRctThumb)
  683.                             If (m_lThumbSize >= GRIPPERSIZE_MIN) Then
  684.                                 Call pvDrawThemePart(lhDC, SB_THEME, SBP_GRIPPERVERT - (lfHorz), VSS_PUSHED, m_uRctThumb)
  685.                             End If
  686.                         Else
  687.                             Call pvDrawThemePart(lhDC, SB_THEME, SBP_THUMBBTNVERT - (lfHorz), VSS_NORMAL, m_uRctThumb)
  688.                             If (m_lThumbSize >= GRIPPERSIZE_MIN) Then
  689.                                Call pvDrawThemePart(lhDC, SB_THEME, SBP_GRIPPERVERT - (lfHorz), VSS_NORMAL, m_uRctThumb)
  690.                             End If
  691.                         End If
  692.                     End If
  693.                 End If
  694.                 If (m_bHasNullTrack) Then
  695.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_UPPERTRACKVERT - (2 * lfHorz), HSS_NORMAL, m_uRctNullTrack)
  696.                 End If
  697.             Else
  698.                 '-- Draw all disabled
  699.                 Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_UPDISABLED + (8 * lfHorz), m_uRctTLButton)
  700.                 Call pvDrawThemePart(lhDC, SB_THEME, SBP_ARROWBTN, ABS_DOWNDISABLED + (8 * lfHorz), m_uRctBRButton)
  701.                 Call pvDrawThemePart(lhDC, SB_THEME, SBP_UPPERTRACKVERT + (2 * lfHorz), HSS_DISABLED, m_uRctTLTrack)
  702.                 If (m_bHasTrack) Then
  703.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_LOWERTRACKVERT + (2 * lfHorz), HSS_DISABLED, m_uRctBRTrack)
  704.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_THUMBBTNVERT - (lfHorz), VSS_DISABLED, m_uRctThumb)
  705.                     If (m_lThumbSize >= GRIPPERSIZE_MIN) Then
  706.                         Call pvDrawThemePart(lhDC, SB_THEME, SBP_GRIPPERVERT - (lfHorz), VSS_DISABLED, m_uRctThumb)
  707.                     End If
  708.                 End If
  709.                 If (m_bHasNullTrack) Then
  710.                     Call pvDrawThemePart(lhDC, SB_THEME, SBP_UPPERTRACKVERT - (2 * lfHorz), HSS_DISABLED, m_uRctNullTrack)
  711.                 End If
  712.             End If
  713.         Case m_eStyle = [sCustomDraw]
  714.             With m_uRctTLButton
  715.                 RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppTLButton], IIf(m_bTLButtonHot, [ppsHot], IIf(m_bTLButtonPressed, [ppsPressed], [ppsNormal])))
  716.             End With
  717.             With m_uRctBRButton
  718.                 RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppBRButton], IIf(m_bBRButtonHot, [ppsHot], IIf(m_bBRButtonPressed, [ppsPressed], [ppsNormal])))
  719.             End With
  720.             If (m_bHasTrack) Then
  721.                 With m_uRctTLTrack
  722.                     RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppTLTrack], IIf(m_bTLTrackPressed, [ppsPressed], [ppsNormal]))
  723.                 End With
  724.                 With m_uRctBRTrack
  725.                     RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppBRTrack], IIf(m_bBRTrackPressed, [ppsPressed], [ppsNormal]))
  726.                 End With
  727.                 With m_uRctThumb
  728.                     RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppThumb], IIf(m_bThumbHot, [ppsHot], IIf(m_bThumbPressed, [ppsPressed], [ppsNormal])))
  729.                 End With
  730.             End If
  731.             If (m_bHasNullTrack) Then
  732.                 With m_uRctNullTrack
  733.                     RaiseEvent OnPaint(lhDC, .x1, .y1, .x2, .y2, [ppNullTrack], [ppsNormal])
  734.                 End With
  735.             End If
  736.     End Select
  737. End Sub
  738.  
  739. Private Sub pvOnMouseDown(ByVal wParam As Long, ByVal lParam As Long)
  740.     If (wParam And MK_LBUTTON = MK_LBUTTON) Then
  741.         Call pvMakePoints(lParam, m_x, m_y)
  742.         m_eHitTest = pvHitTest(m_x, m_y)
  743.         Select Case m_eHitTest
  744.             Case HT_THUMB
  745.                 Select Case m_eOrientation
  746.                     Case [oVertical]
  747.                         m_lThumbOffset = m_uRctThumb.y1 - m_y
  748.                     Case [oHorizontal]
  749.                         m_lThumbOffset = m_uRctThumb.x1 - m_x
  750.                 End Select
  751.                 m_bThumbPressed = True
  752.                 m_bThumbHot = False
  753.                 m_lValueStartDrag = m_lValue
  754.                 Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  755.             Case HT_TLBUTTON
  756.                 m_bTLButtonPressed = True
  757.                 m_bTLButtonHot = False
  758.                 Call pvScrollPosDec(m_lSmallChange, True)
  759.                 Call pvKillTimer(TIMERID_CHANGE1)
  760.                 Call pvSetTimer(TIMERID_CHANGE1, m_lChangeDelay)
  761.             Case HT_BRBUTTON
  762.                 m_bBRButtonPressed = True
  763.                 m_bBRButtonHot = False
  764.                 Call pvScrollPosInc(m_lSmallChange, True)
  765.                 Call pvKillTimer(TIMERID_CHANGE1)
  766.                 Call pvSetTimer(TIMERID_CHANGE1, m_lChangeDelay)
  767.             Case HT_TLTRACK
  768.                 m_bTLTrackPressed = True
  769.                 Call pvScrollPosDec(m_lLargeChange)
  770.                 Call pvKillTimer(TIMERID_CHANGE1)
  771.                 Call pvSetTimer(TIMERID_CHANGE1, m_lChangeDelay)
  772.             Case HT_BRTRACK
  773.                 m_bBRTrackPressed = True
  774.                 Call pvScrollPosInc(m_lLargeChange)
  775.                 Call pvKillTimer(TIMERID_CHANGE1)
  776.                 Call pvSetTimer(TIMERID_CHANGE1, m_lChangeDelay)
  777.         End Select
  778.     End If
  779. End Sub
  780.  
  781. Private Sub pvOnMouseMove(ByVal wParam As Long, ByVal lParam As Long)
  782.     Dim lValuePrev As Long, lThumbPosPrev As Long, bPressed As Boolean, bHot As Boolean
  783.     '
  784.     Call pvMakePoints(lParam, m_x, m_y)
  785.     If (wParam And MK_LBUTTON = MK_LBUTTON) Then
  786.         Select Case m_eHitTest
  787.             Case HT_THUMB
  788.                 lValuePrev = m_lValue
  789.                 lThumbPosPrev = m_lThumbPos
  790.                 If (PtInRect(m_uRctDrag, m_x, m_y)) Then
  791.                     Select Case m_eOrientation
  792.                         Case [oVertical]
  793.                             m_lThumbPos = m_y + m_lThumbOffset
  794.                             If (m_lThumbPos < m_uRctTLButton.y2) Then
  795.                                 m_lThumbPos = m_uRctTLButton.y2
  796.                             End If
  797.                             If (m_lThumbPos + m_lThumbSize > m_uRctBRButton.y1) Then
  798.                                 m_lThumbPos = m_uRctBRButton.y1 - m_lThumbSize
  799.                             End If
  800.                         Case [oHorizontal]
  801.                             m_lThumbPos = m_x + m_lThumbOffset
  802.                             If (m_lThumbPos < m_uRctTLButton.x2) Then
  803.                                 m_lThumbPos = m_uRctTLButton.x2
  804.                             End If
  805.                             If (m_lThumbPos + m_lThumbSize > m_uRctBRButton.x1) Then
  806.                                 m_lThumbPos = m_uRctBRButton.x1 - m_lThumbSize
  807.                             End If
  808.                     End Select
  809.                     m_lValue = pvGetScrollPos()
  810.                 Else
  811.                     m_lValue = m_lValueStartDrag
  812.                     m_lThumbPos = pvGetThumbPos()
  813.                 End If
  814.                 If (m_lThumbPos <> lThumbPosPrev) Then
  815.                     Call pvSizeTrack
  816.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  817.                     If (m_lValue <> lValuePrev) Then
  818.                         RaiseEvent Scroll
  819.                     End If
  820.                 End If
  821.             Case HT_TLBUTTON
  822.                 bPressed = (PtInRect(m_uRctTLButton, m_x, m_y) <> 0)
  823.                 If (bPressed Xor m_bTLButtonPressed) Then
  824.                     m_bTLButtonPressed = bPressed
  825.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  826.                 End If
  827.             Case HT_BRBUTTON
  828.                 bPressed = (PtInRect(m_uRctBRButton, m_x, m_y) <> 0)
  829.                 If (bPressed Xor m_bBRButtonPressed) Then
  830.                     m_bBRButtonPressed = bPressed
  831.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  832.                 End If
  833.         End Select
  834.     Else
  835.         m_eHitTestHot = pvHitTest(m_x, m_y)
  836.         Select Case m_eHitTestHot
  837.             Case HT_TLBUTTON
  838.                 bHot = (PtInRect(m_uRctTLButton, m_x, m_y) <> 0)
  839.                 If (m_bTLButtonHot Xor bHot) Then
  840.                     m_bTLButtonHot = True
  841.                     m_bBRButtonHot = False
  842.                     m_bThumbHot = False
  843.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  844.                     Call pvKillTimer(TIMERID_HOT)
  845.                     Call pvSetTimer(TIMERID_HOT, TIMERDT_HOT)
  846.                 End If
  847.             Case HT_BRBUTTON
  848.                 bHot = (PtInRect(m_uRctBRButton, m_x, m_y) <> 0)
  849.                 If (m_bBRButtonHot Xor bHot) Then
  850.                     m_bTLButtonHot = False
  851.                     m_bBRButtonHot = True
  852.                     m_bThumbHot = False
  853.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  854.                     Call pvKillTimer(TIMERID_HOT)
  855.                     Call pvSetTimer(TIMERID_HOT, TIMERDT_HOT)
  856.                 End If
  857.             Case HT_THUMB
  858.                 bHot = (PtInRect(m_uRctThumb, m_x, m_y) <> 0)
  859.                 If (m_bThumbHot Xor bHot) Then
  860.                     m_bTLButtonHot = False
  861.                     m_bBRButtonHot = False
  862.                     m_bThumbHot = True
  863.                     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  864.                     Call pvKillTimer(TIMERID_HOT)
  865.                     Call pvSetTimer(TIMERID_HOT, TIMERDT_HOT)
  866.                 End If
  867.         End Select
  868.     End If
  869. End Sub
  870.  
  871. Private Sub pvOnMouseUp()
  872.     Call pvKillTimer(TIMERID_HOT)
  873.     Call pvKillTimer(TIMERID_CHANGE1)
  874.     Call pvKillTimer(TIMERID_CHANGE2)
  875.     If (m_eHitTest = HT_THUMB) Then
  876.         If (m_lValue <> m_lValueStartDrag) Then
  877.             RaiseEvent Change
  878.         End If
  879.     End If
  880.     m_eHitTest = HT_NOTHING
  881.     m_bTLButtonPressed = False
  882.     m_bBRButtonPressed = False
  883.     m_bThumbPressed = False
  884.     m_bTLTrackPressed = False
  885.     m_bBRTrackPressed = False
  886.     m_lThumbPos = pvGetThumbPos()
  887.     Call pvSizeTrack
  888.     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  889. End Sub
  890.  
  891. Private Sub pvOnTimer(ByVal wParam As Long)
  892.     Dim uPt As POINTAPI
  893.     Select Case wParam
  894.         Case TIMERID_CHANGE1
  895.             Call pvKillTimer(TIMERID_CHANGE1)
  896.             Call pvSetTimer(TIMERID_CHANGE2, m_lChangeFrequency)
  897.         Case TIMERID_CHANGE2
  898.             Select Case m_eHitTest
  899.                 Case HT_TLBUTTON
  900.                     If (PtInRect(m_uRctTLButton, m_x, m_y)) Then
  901.                         If (pvScrollPosDec(m_lSmallChange) = False) Then
  902.                             Call pvKillTimer(TIMERID_CHANGE2)
  903.                         End If
  904.                     End If
  905.                 Case HT_BRBUTTON
  906.                     If (PtInRect(m_uRctBRButton, m_x, m_y)) Then
  907.                         If (pvScrollPosInc(m_lSmallChange) = False) Then
  908.                             Call pvKillTimer(TIMERID_CHANGE2)
  909.                         End If
  910.                     End If
  911.                 Case HT_TLTRACK
  912.                     Select Case m_eOrientation
  913.                         Case [oVertical]
  914.                             If (m_lThumbPos > m_y) Then
  915.                                 m_bTLTrackPressed = True
  916.                                 Call pvScrollPosDec(m_lLargeChange)
  917.                             Else
  918.                                 m_bTLTrackPressed = False
  919.                                 Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  920.                             End If
  921.                         Case [oHorizontal]
  922.                             If (m_lThumbPos > m_x) Then
  923.                                 m_bTLTrackPressed = True
  924.                                 Call pvScrollPosDec(m_lLargeChange)
  925.                             Else
  926.                                 m_bTLTrackPressed = False
  927.                                 Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  928.                             End If
  929.                     End Select
  930.                 Case HT_BRTRACK
  931.                     Select Case m_eOrientation
  932.                         Case [oVertical]
  933.                             If (m_lThumbPos + m_lThumbSize < m_y) Then
  934.                                 m_bBRTrackPressed = True
  935.                                 Call pvScrollPosInc(m_lLargeChange)
  936.                             Else
  937.                                 m_bBRTrackPressed = False
  938.                                 Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  939.                             End If
  940.                         Case [oHorizontal]
  941.                             If (m_lThumbPos + m_lThumbSize < m_x) Then
  942.                                 m_bBRTrackPressed = True
  943.                                 Call pvScrollPosInc(m_lLargeChange)
  944.                             Else
  945.                                 m_bBRTrackPressed = False
  946.                                 Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  947.                             End If
  948.                     End Select
  949.            End Select
  950.         Case TIMERID_HOT
  951.             Call GetCursorPos(uPt)
  952.             Call ScreenToClient(hwnd, uPt)
  953.             Select Case True
  954.                 Case m_bTLButtonHot
  955.                     If (PtInRect(m_uRctTLButton, uPt.x, uPt.y) = 0) Then
  956.                         m_bTLButtonHot = False
  957.                         Call pvKillTimer(TIMERID_HOT)
  958.                         Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  959.                     End If
  960.                 Case m_bBRButtonHot
  961.                     If (PtInRect(m_uRctBRButton, uPt.x, uPt.y) = 0) Then
  962.                         m_bBRButtonHot = False
  963.                         Call pvKillTimer(TIMERID_HOT)
  964.                         Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  965.                     End If
  966.                 Case m_bThumbHot
  967.                     If (PtInRect(m_uRctThumb, uPt.x, uPt.y) = 0) Then
  968.                         m_bThumbHot = False
  969.                         Call pvKillTimer(TIMERID_HOT)
  970.                         Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  971.                     End If
  972.             End Select
  973.     End Select
  974. End Sub
  975.  
  976. Private Sub pvOnSysColorChange()
  977.     '-- Repaint all
  978.     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  979. End Sub
  980.  
  981. Private Sub pvOnThemeChanged()
  982.     '-- Check OS
  983.     Call pvCheckEnvironment
  984.     RaiseEvent ThemeChanged
  985.     '-- Repaint all
  986.     Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  987. End Sub
  988.  
  989. '========================================================================================
  990. ' Private
  991. '========================================================================================
  992. '----------------------------------------------------------------------------------------
  993. ' Sizing
  994. '----------------------------------------------------------------------------------------
  995. Private Sub pvSizeButtons()
  996.     Dim uRct As RECT, lButtonSize As Long
  997.     '
  998.     Call GetClientRect(hwnd, uRct)
  999.     m_bHasTrack = False
  1000.     m_bHasNullTrack = False
  1001.     Select Case m_eOrientation
  1002.         Case [oVertical]
  1003.             '-- Size buttons
  1004.             lButtonSize = GetSystemMetrics(SM_CYVSCROLL) * -CLng(m_bShowButtons)
  1005.             With uRct
  1006.                 If (2 * lButtonSize + THUMBSIZE_MIN > .y2) Then
  1007.                     If (2 * lButtonSize < .y2) Then
  1008.                         Call SetRect(m_uRctTLButton, 0, 0, .x2, lButtonSize)
  1009.                         Call SetRect(m_uRctBRButton, 0, .y2 - lButtonSize, .x2, .y2)
  1010.                         m_bHasNullTrack = True
  1011.                         Call SetRect(m_uRctNullTrack, 0, lButtonSize, .x2, .y2 - lButtonSize)
  1012.                     Else
  1013.                         Call SetRect(m_uRctTLButton, 0, 0, .x2, .y2 \ 2)
  1014.                         Call SetRect(m_uRctBRButton, 0, .y2 \ 2 + (.y2 Mod 2), .x2, .y2)
  1015.                         m_bHasNullTrack = CBool(.y2 Mod 2)
  1016.                         If (m_bHasNullTrack) Then
  1017.                             Call SetRect(m_uRctNullTrack, 0, .y2 \ 2, .x2, .y2 \ 2 + 1)
  1018.                         End If
  1019.                     End If
  1020.                 Else
  1021.                     m_bHasTrack = True
  1022.                     Call SetRect(m_uRctTLButton, 0, 0, .x2, lButtonSize)
  1023.                     Call SetRect(m_uRctBRButton, 0, .y2 - lButtonSize, .x2, .y2)
  1024.                 End If
  1025.             End With
  1026.             '-- Get max. drag area
  1027.             Call CopyRect(m_uRctDrag, uRct)
  1028.             Call InflateRect(m_uRctDrag, 250, 25)
  1029.         Case [oHorizontal]
  1030.             '-- Size buttons
  1031.             lButtonSize = GetSystemMetrics(SM_CXHSCROLL) * -CLng(m_bShowButtons)
  1032.             With uRct
  1033.                 If (2 * lButtonSize + THUMBSIZE_MIN > .x2) Then
  1034.                     If (2 * lButtonSize < .x2) Then
  1035.                         Call SetRect(m_uRctTLButton, 0, 0, lButtonSize, .y2)
  1036.                         Call SetRect(m_uRctBRButton, .x2 - lButtonSize, 0, .x2, .y2)
  1037.                         m_bHasNullTrack = True
  1038.                         Call SetRect(m_uRctNullTrack, lButtonSize, 0, .x2 - lButtonSize, .y2)
  1039.                     Else
  1040.                         Call SetRect(m_uRctTLButton, 0, 0, .x2 \ 2, .y2)
  1041.                         Call SetRect(m_uRctBRButton, .x2 \ 2 + (.x2 Mod 2), 0, .x2, .y2)
  1042.                         m_bHasNullTrack = CBool(.x2 Mod 2)
  1043.                         If (m_bHasNullTrack) Then
  1044.                             Call SetRect(m_uRctNullTrack, .x2 \ 2, 0, .x2 \ 2 + 1, .y2)
  1045.                         End If
  1046.                     End If
  1047.                 Else
  1048.                     m_bHasTrack = True
  1049.                     Call SetRect(m_uRctTLButton, 0, 0, lButtonSize, .y2)
  1050.                     Call SetRect(m_uRctBRButton, .x2 - lButtonSize, 0, .x2, .y2)
  1051.                 End If
  1052.             End With
  1053.             '-- Get max. drag area
  1054.             Call CopyRect(m_uRctDrag, uRct)
  1055.             Call InflateRect(m_uRctDrag, 25, 250)
  1056.     End Select
  1057.     '-- No track: avoid pvSizeTrack() calcs.
  1058.     If (m_bHasTrack = False) Then
  1059.         Call SetRectEmpty(m_uRctTLTrack)
  1060.         Call SetRectEmpty(m_uRctBRTrack)
  1061.         Call SetRectEmpty(m_uRctThumb)
  1062.     End If
  1063. End Sub
  1064.  
  1065. Private Sub pvSizeTrack()
  1066.     If (m_bHasTrack) Then
  1067.         '-- Tracks and thumbs exist
  1068.         Select Case m_eOrientation
  1069.             Case [oVertical]
  1070.                 '-- Size both track parts and thumb
  1071.                 Call SetRect(m_uRctTLTrack, 0, m_uRctTLButton.y2, m_uRctTLButton.x2, m_lThumbPos)
  1072.                 Call SetRect(m_uRctBRTrack, 0, m_lThumbPos + m_lThumbSize, m_uRctBRButton.x2, m_uRctBRButton.y1)
  1073.                 Call SetRect(m_uRctThumb, 0, m_lThumbPos, m_uRctBRButton.x2, m_lThumbPos + m_lThumbSize)
  1074.             Case [oHorizontal]
  1075.                 '-- Size both track parts and thumb
  1076.                 Call SetRect(m_uRctTLTrack, m_uRctTLButton.x2, 0, m_lThumbPos, m_uRctTLButton.y2)
  1077.                 Call SetRect(m_uRctBRTrack, m_lThumbPos + m_lThumbSize, 0, m_uRctBRButton.x1, m_uRctBRButton.y2)
  1078.                 Call SetRect(m_uRctThumb, m_lThumbPos, 0, m_lThumbPos + m_lThumbSize, m_uRctBRButton.y2)
  1079.         End Select
  1080.     End If
  1081. End Sub
  1082.  
  1083. Private Function pvGetThumbSize() As Long
  1084.     On Error Resume Next
  1085.     Select Case m_eOrientation
  1086.         Case [oVertical]
  1087.             pvGetThumbSize = (m_uRctBRButton.y1 - m_uRctTLButton.y2) \ (m_lAbsRange \ m_lLargeChange + 1)
  1088.             If (pvGetThumbSize < THUMBSIZE_MIN) Then
  1089.                 pvGetThumbSize = THUMBSIZE_MIN
  1090.             End If
  1091.         Case [oHorizontal]
  1092.             pvGetThumbSize = (m_uRctBRButton.x1 - m_uRctTLButton.x2) \ (m_lAbsRange \ m_lLargeChange + 1)
  1093.             If (pvGetThumbSize < THUMBSIZE_MIN) Then
  1094.                 pvGetThumbSize = THUMBSIZE_MIN
  1095.             End If
  1096.     End Select
  1097.     On Error GoTo 0
  1098. End Function
  1099.  
  1100. '----------------------------------------------------------------------------------------
  1101. ' Controling value
  1102. '----------------------------------------------------------------------------------------
  1103. Private Function pvScrollPosDec(ByVal lSteps As Long, Optional ByVal bForceRepaint As Boolean = False) As Boolean
  1104.     Dim bChange As Boolean, lValuePrev As Long
  1105.     '
  1106.     lValuePrev = m_lValue
  1107.     m_lValue = m_lValue - lSteps
  1108.     If (m_lValue < m_lMin) Then
  1109.         m_lValue = m_lMin
  1110.     End If
  1111.     If (m_lValue <> lValuePrev) Then
  1112.         m_lThumbPos = pvGetThumbPos()
  1113.         Call pvSizeTrack
  1114.         bChange = True
  1115.     End If
  1116.     If (bChange Or bForceRepaint) Then
  1117.         Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  1118.         If (bChange) Then
  1119.             RaiseEvent Change
  1120.         End If
  1121.     End If
  1122.     pvScrollPosDec = bChange
  1123. End Function
  1124.  
  1125. Private Function pvScrollPosInc(ByVal lSteps As Long, Optional ByVal bForceRepaint As Boolean = False) As Boolean
  1126.     Dim bChange As Boolean, lValuePrev As Long
  1127.     '
  1128.     lValuePrev = m_lValue
  1129.     m_lValue = m_lValue + lSteps
  1130.     If (m_lValue > m_lMax) Then
  1131.         m_lValue = m_lMax
  1132.     End If
  1133.     If (m_lValue <> lValuePrev) Then
  1134.         m_lThumbPos = pvGetThumbPos()
  1135.         Call pvSizeTrack
  1136.         bChange = True
  1137.     End If
  1138.     If (bChange Or bForceRepaint) Then
  1139.         Call InvalidateRect(UserControl.hwnd, ByVal 0, 0)
  1140.         If (bChange) Then
  1141.             RaiseEvent Change
  1142.         End If
  1143.     End If
  1144.     pvScrollPosInc = bChange
  1145. End Function
  1146.  
  1147. '----------------------------------------------------------------------------------------
  1148. ' Positioning thumb and getting value from thumb position
  1149. '----------------------------------------------------------------------------------------
  1150. Private Function pvGetThumbPos() As Long
  1151.     On Error Resume Next
  1152.     Select Case m_eOrientation
  1153.         Case [oVertical]
  1154.             pvGetThumbPos = m_uRctTLButton.y2
  1155.             pvGetThumbPos = pvGetThumbPos + (m_uRctBRButton.y1 - m_uRctTLButton.y2 - m_lThumbSize) / m_lAbsRange * (m_lValue - m_lMin)
  1156.         Case [oHorizontal]
  1157.             pvGetThumbPos = m_uRctTLButton.x2
  1158.             pvGetThumbPos = pvGetThumbPos + (m_uRctBRButton.x1 - m_uRctTLButton.x2 - m_lThumbSize) / m_lAbsRange * (m_lValue - m_lMin)
  1159.     End Select
  1160.     On Error GoTo 0
  1161. End Function
  1162.  
  1163. Private Function pvGetScrollPos() As Long
  1164.     On Error Resume Next
  1165.     Select Case m_eOrientation
  1166.         Case [oVertical]
  1167.             pvGetScrollPos = m_lMin + (m_lThumbPos - m_uRctTLButton.y2) / (m_uRctBRButton.y1 - m_uRctTLButton.y2 - m_lThumbSize) * m_lAbsRange
  1168.         Case [oHorizontal]
  1169.             pvGetScrollPos = m_lMin + (m_lThumbPos - m_uRctTLButton.x2) / (m_uRctBRButton.x1 - m_uRctTLButton.x2 - m_lThumbSize) * m_lAbsRange
  1170.     End Select
  1171.     On Error GoTo 0
  1172. End Function
  1173.  
  1174. '----------------------------------------------------------------------------------------
  1175. ' Hit-Test
  1176. '----------------------------------------------------------------------------------------
  1177. Private Function pvHitTest(ByVal x As Long, ByVal y As Long) As Long
  1178.     Select Case True
  1179.         Case PtInRect(m_uRctTLButton, x, y)
  1180.             pvHitTest = HT_TLBUTTON
  1181.         Case PtInRect(m_uRctBRButton, x, y)
  1182.             pvHitTest = HT_BRBUTTON
  1183.         Case PtInRect(m_uRctTLTrack, x, y)
  1184.             pvHitTest = HT_TLTRACK
  1185.         Case PtInRect(m_uRctBRTrack, x, y)
  1186.             pvHitTest = HT_BRTRACK
  1187.         Case PtInRect(m_uRctThumb, x, y)
  1188.             pvHitTest = HT_THUMB
  1189.     End Select
  1190. End Function
  1191.  
  1192. Private Sub pvMakePoints(ByVal lPoint As Long, x As Long, y As Long)
  1193.     If (lPoint And &H8000&) Then
  1194.         x = &H8000 Or (lPoint And &H7FFF&)
  1195.     Else
  1196.         x = lPoint And &HFFFF&
  1197.     End If
  1198.     If (lPoint And &H80000000) Then
  1199.         y = (lPoint \ &H10000) - 1
  1200.     Else
  1201.         y = lPoint \ &H10000
  1202.     End If
  1203. End Sub
  1204.  
  1205. '----------------------------------------------------------------------------------------
  1206. ' Timing
  1207. '----------------------------------------------------------------------------------------
  1208. Private Sub pvSetTimer(ByVal lTimerID As Long, ByVal ldT As Long)
  1209.     Call SetTimer(UserControl.hwnd, lTimerID, ldT, 0)
  1210. End Sub
  1211.  
  1212. Private Sub pvKillTimer(ByVal lTimerID As Long)
  1213.     Call KillTimer(UserControl.hwnd, lTimerID)
  1214.     m_eHitTestHot = HT_NOTHING
  1215. End Sub
  1216.  
  1217. '----------------------------------------------------------------------------------------
  1218. ' Painting
  1219. '----------------------------------------------------------------------------------------
  1220. Private Sub pvDrawFlatButton(ByVal hdc As Long, uRct As RECT, ByVal lfArrowDirection As Long, ByVal eState As eFlatButtonStateCts)
  1221.     Dim uRctMem As RECT, hDCMem1 As Long, hDCMem2 As Long
  1222.     Dim hBmp1 As Long, hBmp2 As Long, hBmpOld1 As Long, hBmpOld2 As Long
  1223.     Dim clrBkOld As Long, clrTextOld As Long
  1224.     '
  1225.     With uRct
  1226.         '-- Monochrome bitmap to convert the arrow to black/white mask
  1227.         hDCMem1 = CreateCompatibleDC(hdc)
  1228.         hBmp1 = CreateBitmap(.x2 - .x1, .y2 - .y1, 1, 1, ByVal 0)
  1229.         hBmpOld1 = SelectObject(hDCMem1, hBmp1)
  1230.         '-- Normal bitmap to draw the arrow into
  1231.         hDCMem2 = CreateCompatibleDC(hdc)
  1232.         hBmp2 = CreateCompatibleBitmap(hdc, .x2 - .x1, .y2 - .y1)
  1233.         hBmpOld2 = SelectObject(hDCMem2, hBmp2)
  1234.         '-- Draw frame normaly
  1235.         Call CopyRect(uRctMem, uRct)
  1236.         Call OffsetRect(uRctMem, -.x1, -.y1)
  1237.         Call DrawFrameControl(hDCMem2, uRctMem, DFC_SCROLL, DFCS_FLAT Or lfArrowDirection)
  1238.         Select Case eState
  1239.             Case [fbsNormal]
  1240.                 '-- Nothing to do
  1241.                 Call BitBlt(hdc, .x1, .y1, .x2 - .x1, .y2 - .y1, hDCMem2, 0, 0, vbSrcCopy)
  1242.             Case [fbsSelected]
  1243.                 '-- Invert
  1244.                 Call InvertRect(hDCMem2, uRctMem)
  1245.                 Call BitBlt(hdc, .x1, .y1, .x2 - .x1, .y2 - .y1, hDCMem2, 0, 0, vbSrcCopy)
  1246.             Case [fbsHot]
  1247.                 '-- Mask glyph
  1248.                 Call SetBkColor(hDCMem2, GetSysColor(COLOR_BTNTEXT))
  1249.                 Call BitBlt(hDCMem1, 0, 0, .x2 - .x1, .y2 - .y1, hDCMem2, 0, 0, vbSrcCopy)
  1250.                 clrBkOld = SetBkColor(hdc, GetSysColor(COLOR_3DHIGHLIGHT))
  1251.                 clrTextOld = SetTextColor(hdc, GetSysColor(COLOR_3DSHADOW))
  1252.                 Call BitBlt(hdc, .x1, .y1, .x2 - .x1, .y2 - .y1, hDCMem1, 0, 0, vbSrcCopy)
  1253.                 Call SetBkColor(hdc, clrBkOld)
  1254.                 Call SetTextColor(hdc, clrTextOld)
  1255.         End Select
  1256.     End With
  1257.     '-- Clean up
  1258.     Call DeleteObject(SelectObject(hDCMem1, hBmpOld1))
  1259.     Call DeleteObject(SelectObject(hDCMem2, hBmpOld2))
  1260.     Call DeleteDC(hDCMem1)
  1261.     Call DeleteDC(hDCMem2)
  1262. End Sub
  1263.  
  1264. Private Function pvDrawThemePart(ByVal lhDC As Long, ByVal sClass As String, ByVal lPart As Long, ByVal lState As Long, lpRect As RECT) As Boolean
  1265.     Dim hTheme As Long
  1266.     On Error GoTo Catch
  1267.     '
  1268.     hTheme = OpenThemeData(UserControl.hwnd, StrPtr(sClass))
  1269.     If (hTheme <> 0) Then
  1270.         pvDrawThemePart = (DrawThemeBackground(hTheme, lhDC, lPart, lState, lpRect, lpRect) = 0)
  1271.     End If
  1272. Catch:
  1273.     On Error GoTo 0
  1274. End Function
  1275.  
  1276. '----------------------------------------------------------------------------------------
  1277. ' Misc.
  1278. '----------------------------------------------------------------------------------------
  1279. '-- Creating a pattern bitmap (track)
  1280. Private Sub pvCreatePatternBrush()
  1281.     Dim hBitmap As Long, nPattern(1 To 8) As Integer
  1282.     '
  1283.     '-- Brush pattern (8x8)
  1284.     nPattern(1) = &HAA
  1285.     nPattern(2) = &H55
  1286.     nPattern(3) = &HAA
  1287.     nPattern(4) = &H55
  1288.     nPattern(5) = &HAA
  1289.     nPattern(6) = &H55
  1290.     nPattern(7) = &HAA
  1291.     nPattern(8) = &H55
  1292.     '-- Create brush from bitmap
  1293.     hBitmap = CreateBitmap(8, 8, 1, 1, nPattern(1))
  1294.     m_hPatternBrush = CreatePatternBrush(hBitmap)
  1295.     Call DeleteObject(hBitmap)
  1296. End Sub
  1297.  
  1298. '-- Checking environment and Windows theming
  1299. Private Sub pvCheckEnvironment()
  1300.     'modified by Jason James Newland 2007
  1301.     Dim uOSV As OSVERSIONINFO
  1302.     '
  1303.     m_bIsXP = False
  1304.     m_bIsLuna = False
  1305.     With uOSV
  1306.         .dwOSVersionInfoSize = Len(uOSV)
  1307.         Call GetVersionEx(uOSV)
  1308.         If (.dwPlatformId = 2) Then
  1309.             If (.dwMajorVersion = 5) Then     ' NT based
  1310.                 If (.dwMinorVersion > 0) Then ' XP
  1311.                     m_bIsXP = True
  1312.                     m_bIsLuna = pvIsLuna()
  1313.                 End If
  1314.             ElseIf .dwMajorVersion = 6 Then
  1315.                 If .dwMinorVersion = 0 Then 'Vista
  1316.                     m_bIsXP = True
  1317.                     m_bIsLuna = pvIsLuna()
  1318.                 End If
  1319.             End If
  1320.         End If
  1321.     End With
  1322. End Sub
  1323.  
  1324. Private Function pvIsLuna() As Boolean
  1325.     'modified by Jason James Newland 2007
  1326.     Dim hLib   As Long, lPos  As Long, sTheme As String, sName As String
  1327.     '-- Be sure that the theme dll is present
  1328.     hLib = LoadLibrary("uxtheme.dll")
  1329.     If (hLib <> 0) Then
  1330.         '-- Get the theme file name
  1331.         sTheme = String$(255, 0)
  1332.         Call GetCurrentThemeName(StrPtr(sTheme), Len(sTheme), 0, 0, 0, 0)
  1333.         lPos = InStr(1, sTheme, Chr$(0))
  1334.         If (lPos > 0) Then
  1335.             '-- Get the canonical theme name
  1336.             sTheme = Left$(sTheme, lPos - 1)
  1337.             sName = String$(255, 0)
  1338.             Call GetThemeDocumentationProperty(StrPtr(sTheme), StrPtr("ThemeName"), StrPtr(sName), Len(sName))
  1339.             lPos = InStr(1, sName, Chr$(0))
  1340.             If (lPos > 0) Then
  1341.                 '-- Is it Luna or Areo?
  1342.                 sName = Left$(sName, lPos - 1)
  1343.                 pvIsLuna = IIf(LenB(sName) <> 0, True, False)
  1344.             End If
  1345.         End If
  1346.         Call FreeLibrary(hLib)
  1347.     End If
  1348. End Function
  1349.  
  1350. '========================================================================================
  1351. ' UserControl persistent properties
  1352. '========================================================================================
  1353. Private Sub UserControl_InitProperties()
  1354.     '-- Initialization default values
  1355.     Let m_lChangeDelay = CHANGEDELAY_DEF
  1356.     Let m_lChangeFrequency = CHANGEFREQUENCY_DEF
  1357.     Let m_lMin = MIN_DEF
  1358.     Let m_lMax = MAX_DEF
  1359.     Let m_lValue = VALUE_DEF
  1360.     Let m_lSmallChange = SMALLCHANGE_DEF
  1361.     Let m_lLargeChange = LARGECHANGE_DEF
  1362.     Let m_eOrientation = ORIENTATION_DEF
  1363.     Let m_eStyle = STYLE_DEF
  1364.     Let m_bShowButtons = SHOWBUTTONS_DEF
  1365.     
  1366.     '-- Initialize rectangles
  1367.     Let m_lAbsRange = m_lMax - m_lMin
  1368.     Call pvSizeButtons
  1369.     m_lThumbSize = pvGetThumbSize()
  1370.     m_lThumbPos = pvGetThumbPos()
  1371.     Call pvSizeTrack
  1372. End Sub
  1373.  
  1374. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  1375.     '-- Bag properties
  1376.     With PropBag
  1377.         '-- Read inherently-stored properties
  1378.         Let UserControl.Enabled = .ReadProperty("Enabled", ENABLED_DEF)
  1379.         '-- Read 'memory' properties
  1380.         Let m_lMin = .ReadProperty("Min", MIN_DEF)
  1381.         Let m_lMax = .ReadProperty("Max", MAX_DEF)
  1382.         Let m_lValue = .ReadProperty("Value", VALUE_DEF)
  1383.         Let m_lSmallChange = .ReadProperty("SmallChange", SMALLCHANGE_DEF)
  1384.         Let m_lLargeChange = .ReadProperty("LargeChange", LARGECHANGE_DEF)
  1385.         Let m_lChangeDelay = .ReadProperty("ChangeDelay", CHANGEDELAY_DEF)
  1386.         Let m_lChangeFrequency = .ReadProperty("ChangeFrequency", CHANGEFREQUENCY_DEF)
  1387.         Let m_eOrientation = .ReadProperty("Orientation", ORIENTATION_DEF)
  1388.         Let m_eStyle = .ReadProperty("Style", STYLE_DEF)
  1389.         Let m_bShowButtons = .ReadProperty("ShowButtons", SHOWBUTTONS_DEF)
  1390.     End With
  1391.     '-- Initialize rectangles
  1392.     Let m_lAbsRange = m_lMax - m_lMin
  1393.     Call pvSizeButtons
  1394.     m_lThumbSize = pvGetThumbSize()
  1395.     m_lThumbPos = pvGetThumbPos()
  1396.     Call pvSizeTrack
  1397.     '-- Run-time?
  1398.     If (Ambient.UserMode) Then
  1399.         '-- Check OS and Luna theme
  1400.         Call pvCheckEnvironment
  1401.         '-- Subclass UC window and process following messages
  1402.         Call Subclass_Start(UserControl.hwnd)
  1403.         Call Subclass_AddMsg(UserControl.hwnd, WM_PAINT, [MSG_BEFORE]               Call SetRect(m_uRctBRTrack, 0, m_lThumbPoRect(m_uRctBRTrack, 0                          m_bTLTrackPressek, 0, m_l(eChange = LARGECHANGE_DEF
  1404.     RIEN
  1405.      = (DrawTh, [MSG_BEFORE UserControl_ReadProperties(Prop, [MSG_BEFrngeM   If (.dwPlatformId = 2) Then
  1406.     pBEFrngG_BEngLAY_D             2) Then
  1407.   EFren
  1408.     $           adProF
  1409.     RIENlllllllrawTh, [MSiM
  1410.                                 m_bTLTra l5ss_Start(Usen James Newland 2007
  1411.     Dim hLiO Dim hLiO DBEFORE UserbiHVStart(Usen 8l(eCf (Amemory' propertiealization def= .Read   ll DrawFrameControl(hDCMem2Cll DrawFrameContro Call Subclaseall In elue - m_lMin)
  1412.   nquen_DEl Subclasea_ameContro CallmBnquen_DEl Subclei07
  1413. Fs
  1414.         Calquen_DEl Subclei07
  1415. Fs
  1416.         Calquen_DEl Subclei07
  1417. Fs
  1418.         Calquen_DEl Subclei07
  1419. Fs
  1420.         CjadPrope theme
  1421.         Call pvCheckEnviS(lquen_DEl'-- Read 'memory' properties
  1422.         Let m_lMin = .ReadProperty("Min", MIN_a properties
  1423.         Let m_lMin =4SmallChange = S   Let m       sNGE_DEF
  1424.     RIEN
  1425.      = (
  1426. Private DCMem1, hBmS   Let m       sNGE_DEF
  1427.     RIEN
  1428.      = (
  1429. Private DCMem1, hBmS   Let m 4 Read 'memor
  1430.    iPos(0M (
  1431. Priv eadProperty("Sh
  1432.    iPos(0MateRect(UserCo(0M (
  1433. Priv DrawFraead   ll DrawFrameControl(hIf
  1434.         Call FreeLibrary(hLib)
  1435.     End If
  1436. EEEEEE(lasea
  1437. End S propertL  End Ifironment
  1438.     RaiseEvent ThemeChanged
  1439. drag area
  1440.             Call CopyRect(m_uRctDrag, uRct)
  1441. m_lMin =4SmallCh0    t
  1442.       rmal bitm
  1443.         End If
  1444.    z
  1445.     ======1RctDrag,  
  1446.     ======
  1447. drag s Newla  If (A  pvGetThumbSize- Be sure that thmesBe = STYLE_DEF
  1448.     Let m_bSF
  1449.    lxl tmReadPrM
  1450.         Let m_ldPr   iPos(0Mt m_bSF= AAAAA STYLE_xtheme.dll")
  1451. 07
  1452.   snd  As Long, lpRectag
  1453.   Aet m    Select
  1454.     8
  1455.     RIEN
  1456.      =) Then
  1457.    e su,vxpuRct)
  1458. m_lMin =wButtons = 7
  1459.   snd  As Long, lpRectag
  1460.   Aet m    Select
  1461.     8
  1462.     RIEN
  1463.      =) Then
  1464.    e Be sure xs Be sure xs Be sure xs Bexnna = False
  1465.    ge = S      Let m_lMin = .ReadProperty("Min", Be suubcl.N(,g
  1466.           Call
  1467.    ge = S      pvHitTest =    '  snd  As Lonl Delete?mXrt =    '  s'me, lPo       m_bHasNullTracklTpen
  1468.    persistentRange.HasNullTracklTpen
  1469.    sviS(lquen_DEl'-- Read 'memory'rsbviS(lquen_DEl'-- ReantRange.HasDDrag,  
  1470.     =rt = FEl'-        Call Su,Drag, uRct)
  1471. m U.HasDDrag,  
  1472.     =rt = FEl'-        Call 'memory'rsbviS(lquen_DEl'-- RePodPr,Cag,  
  1473.     =rt = FEl'-        CalrChange()
  1474.  El' If (2 * l snd  As Long,UserControl_ReadProP   gCall Subcl4sp2_-------------- El' If (2 * l snd  As Long,UserControl_ReadProP   gCall Subcl4sp2_--------------  sure thatrol_ReadProperties(Prop, [MSG_BEFrngeM   If (.dwPlatformId = 2) Then
  1475.     pBEFrngG_BEngLAY_Dtheme.dll"eop, [MSLCM_BEngLAY_Do (0
  1476.    e su,vxpuRct)
  1477. dPr,Cag,r,Ca (2 *td  As Long,     Ca_Ca (r,Cag,r,Ca (2 *td  As Lon_Ca (r,Cag,r,CLong,     Ca_Cate,Cag,r,CLong,    g,r,CLong,  BEFORE UserbiHVSta *td  As LoCng,Call SueleteDC(hDCMem2)
  1478. EndsFrngeM   If (.LCMn", Msure xs Be sge As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  As  A   =rt = FEternBrush(hBitmap)
  1479.     Call Dele_DEF
  1480.     RIEN
  1481.      = (
  1482. Private DCMem1, hBmS   Let m 4 Read 'memor
  1483.    iPDem1, hBmS   Subclei07
  1484. Fs
  1485.         = (
  1486. PC
  1487.   ng,  BEePodPr,Cag,  
  1488.     =rth
  1489. End Sub
  1490.  
  1491. Pri As  .
  1492.    ge = S 8i? =rth
  1493. E2 *td  As Lonnl Subclei07
  1494. Fs
  1495.         Calq8_DEF
  1496.     RIEN
  1497.      = (
  1498. Private DCMem1, hBm O