vbAccelerator - Contents of code file: dibViewPort.ctl

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

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Const PS_SOLID = 0
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal x As
 Long, ByVal y As Long) As Long

Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal
 nXOrg As Long, ByVal nYOrg As Long, lppt As POINTAPI) As Long

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" ( _
    ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" ( _
   ByVal hLibModule As Long) As Long

Public Enum espBorderStyle
   espNone = 0
   esp3d = 1
End Enum
Public Enum espBackgroundStyle
   espStandard = 0
   espCheckerboard = 1
End Enum
Public Enum espPictureAlignStyle
   espNear = 0
   espCentre = 1
End Enum

' Internal
Private m_bUserMode  As Boolean
Private m_cD As cAlphaDibSection
Private m_hBmpChecker As Long
Private m_hBrChecker As Long
Private m_hMod As Long

' Properties
Private m_oGridLineColor As OLE_COLOR
Private m_eBorderStyle As espBorderStyle
Private m_eBackStyle As espBackgroundStyle
Private m_eAlign As espPictureAlignStyle
Private m_lVerticalGridSize As Long
Private m_lHorizontalGridSize As Long


' ===========================================================================
' Name:     cScrollBars
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     24 December 1998
' Requires: SSUBTMR.DLL
'
' ---------------------------------------------------------------------------
' Copyright  1998 Steve McMahon (steve@vbaccelerator.com)
' Visit vbAccelerator - free, advanced source code for VB programmers.
'     http://vbaccelerator.com
' ---------------------------------------------------------------------------
'
' Description:
' A class which can add scroll bars to VB Forms, Picture Boxes and
' UserControls.
' Features:
'  * True API scroll bars, which don't flash or draw badly like
'    the VB ones
'  * Scroll bar values are long integers, i.e. >2 billion values
'  * Set Flat or Encarta scroll bar modes if your COMCTL32.DLL version
'    supports it (>4.72)
'
' Updates:
' 2003-07-02
'  * Added Mouse Wheel Support.  Thanks to Chris Eastwood for
'    the suggestion and starter code.
'    Visit his site at http://vbcodelibrary.co.uk/
'  * Scroll bar now goes to bottom when SB_BOTTOM fired
'    (e.g. right click on scroll bar with mouse)
'  * New ScrollClick events to enable focus
'  * Removed a large quantity of redundant declares which
'    had found their way into this class somehow...
' ===========================================================================


' ---------------------------------------------------------------------
' vbAccelerator Software License
' Version 1.0
' Copyright (c) 2002 vbAccelerator.com
'
' Redistribution and use in source and binary forms, with or
' without modification, are permitted provided that the following
' conditions are met:
'
' 1. Redistributions of source code must retain the above copyright
'    notice, this list of conditions and the following disclaimer.
'
' 2. Redistributions in binary form must reproduce the above copyright
'    notice, this list of conditions and the following disclaimer in
'    the documentation and/or other materials provided with the distribution.
'
' 3. The end-user documentation included with the redistribution, if any,
'    must include the following acknowledgment:
'
'  "This product includes software developed by vbAccelerator
 (/index.html)."
'
' Alternately, this acknowledgment may appear in the software itself, if
' and wherever such third-party acknowledgments normally appear.
'
' 4. The name "vbAccelerator" must not be used to endorse or promote products
'    derived from this software without prior written permission. For written
'    permission, please contact vbAccelerator through steve@vbaccelerator.com.
'
' 5. Products derived from this software may not be called "vbAccelerator",
'    nor may "vbAccelerator" appear in their name, without prior written
'    permission of vbAccelerator.
'
' THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED WARRANTIES,
' INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
' AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
' VBACCELERATOR OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
' INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
' BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
' USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
' THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' ---------------------------------------------------------------------

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
 (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias
 "RegisterWindowMessageA" (ByVal lpString As String) As Long
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

'private declare function InitializeFlatSB(HWND) as long
Private Declare Function InitialiseFlatSB Lib "comctl32.dll" Alias
 "InitializeFlatSB" (ByVal lHWnd As Long) As Long

' Scroll bar:
Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type
Private Declare Function SetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal
 n As Long, lpcScrollInfo As SCROLLINFO, ByVal BOOL As Boolean) As Long
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal
 n As Long, LPSCROLLINFO As SCROLLINFO) As Long
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal
 nBar As Long) As Long
Private Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal
 nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
Private Declare Function SetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal
 nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
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
    Private Const SB_BOTH = 3
    Private Const SB_BOTTOM = 7
    Private Const SB_CTL = 2
    Private Const SB_ENDSCROLL = 8
    Private Const SB_HORZ = 0
    Private Const SB_LEFT = 6
    Private Const SB_LINEDOWN = 1
    Private Const SB_LINELEFT = 0
    Private Const SB_LINERIGHT = 1
    Private Const SB_LINEUP = 0
    Private Const SB_PAGEDOWN = 3
    Private Const SB_PAGELEFT = 2
    Private Const SB_PAGERIGHT = 3
    Private Const SB_PAGEUP = 2
    Private Const SB_RIGHT = 7
    Private Const SB_THUMBPOSITION = 4
    Private Const SB_THUMBTRACK = 5
    Private Const SB_TOP = 6
    Private Const SB_VERT = 1

    Private Const SIF_RANGE = &H1
    Private Const SIF_PAGE = &H2
    Private Const SIF_POS = &H4
    Private Const SIF_DISABLENOSCROLL = &H8
    Private Const SIF_TRACKPOS = &H10
    Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)

   Private Const ESB_DISABLE_BOTH = &H3
   Private Const ESB_ENABLE_BOTH = &H0
   
   Private Const SBS_SIZEGRIP = &H10&
   
Private Declare Function EnableScrollBar Lib "user32" (ByVal hwnd As Long,
 ByVal wSBflags As Long, ByVal wArrows As Long) As Long
Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, ByVal
 wBar As Long, ByVal bShow As Long) As Long

' Non-client messages:
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_NCMBUTTONDOWN = &HA7

' Hit test codes for scroll bars:
Private Const HTHSCROLL = 6
Private Const HTVSCROLL = 7

' Scroll bar messages:
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WM_MOUSEWHEEL = &H20A

' Mouse wheel stuff:
Private Const WHEEL_DELTA = 120
Private Const WHEEL_PAGESCROLL = -1
Private Const SPI_GETWHEELSCROLLLINES = &H68

' Old school Wheel Mouse is not supported in this class.
' NT3.51 or Win95 only
'// Class name for MSWHEEL.EXE's invisible window
'// use FindWindow to get hwnd to MSWHEEL
Private Const MSH_MOUSEWHEEL = "MSWHEEL_ROLLMSG"
Private Const MSH_WHEELMODULE_CLASS = "MouseZ"
Private Const MSH_WHEELMODULE_TITLE = "Magellan MSWHEEL"
'// Apps need to call RegisterWindowMessage using the #defines
'// below to get the message numbers for:
'// 1) the message that can be sent to the MSWHEEL window to
'//    query if wheel support is active (MSH_WHEELSUPPORT)>
'// 2) the message to query for the number of scroll lines
'//    (MSH_SCROLL_LINES)
'//
'// To send a message to MSWheel window, use FindWindow with the #defines
'// for CLASS and TITLE above.  If FindWindow fails to find the MSWHEEL
'// window or the return from SendMessage is false, then Wheel support
'// is not currently available.
Private Const MSH_WHEELSUPPORT = "MSH_WHEELSUPPORT_MSG"
Private Const MSH_SCROLL_LINES = "MSH_SCROLL_LINES_MSG"

' Flat scroll bars:
Private Const WSB_PROP_CYVSCROLL = &H1&
Private Const WSB_PROP_CXHSCROLL = &H2&
Private Const WSB_PROP_CYHSCROLL = &H4&
Private Const WSB_PROP_CXVSCROLL = &H8&
Private Const WSB_PROP_CXHTHUMB = &H10&
Private Const WSB_PROP_CYVTHUMB = &H20&
Private Const WSB_PROP_VBKGCOLOR = &H40&
Private Const WSB_PROP_HBKGCOLOR = &H80&
Private Const WSB_PROP_VSTYLE = &H100&
Private Const WSB_PROP_HSTYLE = &H200&
Private Const WSB_PROP_WINSTYLE = &H400&
Private Const WSB_PROP_PALETTE = &H800&
Private Const WSB_PROP_MASK = &HFFF&

Private Const FSB_FLAT_MODE = 2&
Private Const FSB_ENCARTA_MODE = 1&
Private Const FSB_REGULAR_MODE = 0&

Private Declare Function FlatSB_EnableScrollBar Lib "comctl32.dll" (ByVal hwnd
 As Long, ByVal int2 As Long, ByVal UINT3 As Long) As Long
Private Declare Function FlatSB_ShowScrollBar Lib "comctl32.dll" (ByVal hwnd As
 Long, ByVal code As Long, ByVal fRedraw As Boolean) As Long

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
Private Declare Function FlatSB_GetScrollInfo Lib "comctl32.dll" (ByVal hwnd As
 Long, ByVal code As Long, LPSCROLLINFO As SCROLLINFO) As Long
Private Declare Function FlatSB_GetScrollPos Lib "comctl32.dll" (ByVal hwnd As
 Long, ByVal code As Long) As Long
Private Declare Function FlatSB_GetScrollProp Lib "comctl32.dll" (ByVal hwnd As
 Long, ByVal propIndex As Long, ByVal LPINT As Long) As Long

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
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
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
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

Private Declare Function InitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As
 Long) As Long
Private Declare Function UninitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As
 Long) As Long

' XP detection
Private Declare Function GetVersion Lib "kernel32" () As Long

' Message response:
Implements ISubclass
Private m_emr As EMsgResponse

' Initialisation state:
Private m_bInitialised As Boolean

' Orientation
Private Enum EFSOrientationConstants
    efsoHorizontal
    efsoVertical
    efsoBoth
End Enum
Private m_eOrientation As EFSOrientationConstants

' Style
Private Enum EFSStyleConstants
    efsRegular = FSB_REGULAR_MODE
    efsEncarta = FSB_ENCARTA_MODE
    efsFlat = FSB_FLAT_MODE
End Enum
Private m_eStyle As EFSStyleConstants
' Bars:
Private Enum EFSScrollBarConstants
   efsHorizontal = SB_HORZ
   efsVertical = SB_VERT
End Enum

' Can we have flat scroll bars?
Private m_bNoFlatScrollBars As Boolean

' hWnd we're adding scroll bars too:
Private m_hWnd As Long

' Small change amount
Private m_lSmallChangeHorz As Long
Private m_lSmallChangeVert As Long
' Enabled:
Private m_bEnabledHorz As Boolean
Private m_bEnabledVert As Boolean
' Visible
Private m_bVisibleHorz As Boolean
Private m_bVisibleVert As Boolean

' Number of lines to scroll for each wheel click:
Private m_lWheelScrollLines  As Long

Public Property Get BackgroundStyle() As espBackgroundStyle
   BackgroundStyle = m_eBackStyle
End Property
Public Property Let BackgroundStyle(ByVal eStyle As espBackgroundStyle)
   If Not (eStyle = m_eBackStyle) Then
      m_eBackStyle = eStyle
      pPaint
      PropertyChanged "BackgroundStyle)"
   End If
End Property
Public Property Get PictureAlign() As espPictureAlignStyle
   PictureAlign = m_eAlign
End Property
Public Property Let PictureAlign(ByVal eStyle As espPictureAlignStyle)
   If Not (eStyle = m_eAlign) Then
      m_eAlign = eStyle
      pPaint
      PropertyChanged "PictureAlign"
   End If
End Property
Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
   UserControl.BackColor = oColor
   PropertyChanged "BackColor"
End Property
Public Property Get GridLineColor() As OLE_COLOR
   GridLineColor = m_oGridLineColor
End Property
Public Property Let GridLineColor(ByVal oColor As OLE_COLOR)
   m_oGridLineColor = oColor
   pPaint
   PropertyChanged "GridLineColor"
End Property
Public Property Get VerticalGridSize() As Long
   VerticalGridSize = m_lVerticalGridSize
End Property
Public Property Let VerticalGridSize(ByVal lSize As Long)
   m_lVerticalGridSize = lSize
   pPaint
   PropertyChanged "VerticalGridSize"
End Property
Public Property Get HorizontalGridSize() As Long
   HorizontalGridSize = m_lHorizontalGridSize
End Property
Public Property Let HorizontalGridSize(ByVal lSize As Long)
   m_lHorizontalGridSize = lSize
   pPaint
   PropertyChanged "HorizontalGridSize"
End Property

Public Property Get BorderStyle() As espBorderStyle
   BorderStyle = m_eBorderStyle
End Property
Public Property Let BorderStyle(ByVal eStyle As espBorderStyle)
Dim lStyle As Long
   m_eBorderStyle = eStyle
   UserControl.BorderStyle = IIf(eStyle > espNone, 1, 0)
   pPaint
   PropertyChanged "BorderStyle"
End Property

Public Property Let DibSection(cD As cAlphaDibSection)
   pSetDibSection cD
End Property
Public Property Set DibSection(cD As cAlphaDibSection)
   pSetDibSection cD
End Property
Public Property Get DibSection() As cAlphaDibSection
   Set DibSection = m_cD
End Property
Private Sub pSetDibSection(cD As cAlphaDibSection)
   Set m_cD = cD
   If (m_cD Is Nothing) Then
      Value(efsHorizontal) = 0
      Visible(efsHorizontal) = False
      Value(efsVertical) = 0
      Visible(efsHorizontal) = False
      UserControl.Cls
   Else
      pSize
      pPaint
   End If
End Sub

Private Sub pSize()
   Dim tR As RECT
   Dim lWidth As Long
   Dim lHeight As Long
   GetClientRect UserControl.hwnd, tR
   lWidth = tR.right - tR.left
   lHeight = tR.bottom - tR.top
   If (m_cD Is Nothing) Then
      If (Visible(efsHorizontal)) Then
         Value(efsHorizontal) = 0
         Visible(efsHorizontal) = False
      End If
      If (Visible(efsVertical)) Then
         Value(efsVertical) = 0
         Visible(efsVertical) = False
      End If
   Else
      
      If (lWidth < m_cD.Width) Then
         Max(efsHorizontal) = m_cD.Width - lWidth
         If Not (Visible(efsHorizontal)) Then
            Visible(efsHorizontal) = True
            LargeChange(efsHorizontal) = lWidth - 32
            SmallChange(efsHorizontal) = 32
         End If
      Else
         If (Visible(efsHorizontal)) Then
            Value(efsHorizontal) = 0
            Visible(efsHorizontal) = False
         End If
      End If
      GetClientRect UserControl.hwnd, tR
      lWidth = tR.right - tR.left
      lHeight = tR.bottom - tR.top
      If (lHeight < m_cD.Height) Then
         Max(efsVertical) = m_cD.Height - lHeight
         If Not (Visible(efsVertical)) Then
            Visible(efsVertical) = True
            LargeChange(efsVertical) = lHeight - 32
            SmallChange(efsVertical) = 32
         End If
      Else
         If (Visible(efsVertical)) Then
            Value(efsVertical) = 0
            Visible(efsVertical) = False
         End If
      End If
      GetClientRect UserControl.hwnd, tR
      If Not (lWidth = tR.bottom - tR.top) Then
         If (lWidth < m_cD.Width) Then
            Max(efsHorizontal) = m_cD.Width - lWidth
            If Not (Visible(efsHorizontal)) Then
               Visible(efsHorizontal) = True
               LargeChange(efsHorizontal) = lWidth - 32
               SmallChange(efsHorizontal) = 32
            End If
         Else
            If (Visible(efsHorizontal)) Then
               Value(efsHorizontal) = 0
               Visible(efsHorizontal) = False
            End If
         End If
      End If
   End If
End Sub

Private Sub CreateCheckerBrush()
   
   Dim cD As New cAlphaDibSection
   Dim hBr As Long
   Dim tBr As RECT
   
   cD.Create 32, 32
   hBr = CreateSolidBrush(&HFFFFFF)
   tBr.right = 32
   tBr.bottom = 32
   FillRect cD.hDC, tBr, hBr
   DeleteObject hBr
   hBr = CreateSolidBrush(&HF0F0F0)
   tBr.right = 16
   tBr.bottom = 16
   FillRect cD.hDC, tBr, hBr
   OffsetRect tBr, 16, 16
   FillRect cD.hDC, tBr, hBr
   DeleteObject hBr

   m_hBmpChecker = cD.ExtractHBmp

End Sub

Private Sub DrawCheckerBoard(ByVal lhDC As Long, ByRef tR As RECT)
Dim tBr As RECT
Dim tROut As RECT
Dim hBr As Long
Dim x As Long
Dim y As Long
Dim tOld As POINTAPI
Dim lR As Long

   If (m_hBmpChecker = 0) Then
      CreateCheckerBrush
   End If

   If (m_hBrChecker = 0) Then
      m_hBrChecker = CreatePatternBrush(m_hBmpChecker)
   End If
   
   LSet tROut = tR
   If (Visible(efsHorizontal)) Then
      x = Value(efsHorizontal)
   Else
      If Not (m_cD Is Nothing) And (m_eAlign = espCentre) Then
         x = -((tR.right - tR.left) - m_cD.Width) \ 2
      End If
   End If
   If (Visible(efsVertical)) Then
      y = Value(efsVertical)
   Else
      If Not (m_cD Is Nothing) And (m_eAlign = espCentre) Then
         y = -((tR.bottom - tR.top) - m_cD.Height) \ 2
      End If
   End If
   
   lR = SetBrushOrgEx(hDC, -x, -y, tOld)
   
   FillRect lhDC, tROut, m_hBrChecker
   
   
End Sub

Private Sub pPaint()
   UserControl.Cls
   
   Dim tR As RECT
   Dim lColor As Long
   Dim hBr As Long
      
   GetClientRect UserControl.hwnd, tR
   If (m_eBackStyle = espCheckerboard) Then
      '
      DrawCheckerBoard UserControl.hDC, tR
      '
   End If
   
   If Not (m_cD Is Nothing) Then
      Dim lWidth As Long
      Dim lHeight As Long
      Dim lLeft As Long
      Dim lTop As Long
      
      lWidth = tR.right - tR.left
      lHeight = tR.bottom - tR.top
      
      If (Visible(efsHorizontal)) Then
         If (lWidth + Value(efsHorizontal) > m_cD.Width) Then
            lWidth = m_cD.Width - Value(efsHorizontal)
         End If
      Else
         If (m_eAlign = espCentre) Then
            lLeft = (lWidth - m_cD.Width) \ 2
         End If
         lWidth = m_cD.Width
      End If
      If (Visible(efsVertical)) Then
         If (lHeight + Value(efsVertical) > m_cD.Height) Then
            lHeight = m_cD.Height - Value(efsVertical)
         End If
      Else
         If (m_eAlign = espCentre) Then
            lTop = (lHeight - m_cD.Height) \ 2
         End If
         lHeight = m_cD.Height
      End If
      m_cD.AlphaPaintPicture UserControl.hDC, _
         lLeft, lTop, lWidth, lHeight, Value(efsHorizontal), Value(efsVertical)
      
      Dim lPenColor As Long
      Dim hPen As Long
      Dim hPenOld As Long
      Dim pos As Long
      Dim tP As POINTAPI
      OleTranslateColor GridLineColor, 0, lPenColor
      hPen = CreatePen(PS_SOLID, 1, lPenColor)
      hPenOld = SelectObject(UserControl.hDC, hPen)
      If (m_lVerticalGridSize > 1) Then
         pos = -Value(efsVertical) + lTop
         Do While pos < m_cD.Height + 1 And pos <= tR.bottom
            MoveToEx UserControl.hDC, 0, pos, tP
            LineTo UserControl.hDC, IIf(tR.right < m_cD.Width, tR.right,
             m_cD.Width), pos
            pos = pos + m_lVerticalGridSize
         Loop
      End If
      If (m_lHorizontalGridSize > 1) Then
         pos = -Value(efsHorizontal) + lLeft
         Do While pos < m_cD.Width + 1 And pos <= tR.right
            MoveToEx UserControl.hDC, pos, 0, tP
            LineTo UserControl.hDC, pos, IIf(tR.bottom < m_cD.Height,
             tR.bottom, m_cD.Height)
            pos = pos + m_lHorizontalGridSize
         Loop
      End If
      SelectObject UserControl.hDC, hPenOld
      DeleteObject hPen
      
   End If
   
   UserControl.Refresh
      
End Sub

Private Property Get Visible(ByVal eBar As EFSScrollBarConstants) As Boolean
   If (eBar = efsHorizontal) Then
      Visible = m_bVisibleHorz
   Else
      Visible = m_bVisibleVert
   End If
End Property
Private Property Let Visible(ByVal eBar As EFSScrollBarConstants, ByVal bState
 As Boolean)
   If (eBar = efsHorizontal) Then
      m_bVisibleHorz = bState
   Else
      m_bVisibleVert = bState
   End If
   If (m_bNoFlatScrollBars) Then
      ShowScrollBar m_hWnd, eBar, Abs(bState)
   Else
      FlatSB_ShowScrollBar m_hWnd, eBar, Abs(bState)
   End If
End Property

Private Property Get Orientation() As EFSOrientationConstants
   Orientation = m_eOrientation
End Property

Private Property Let Orientation(ByVal eOrientation As EFSOrientationConstants)
   m_eOrientation = eOrientation
   pSetOrientation
End Property

Private Sub pSetOrientation()
   ShowScrollBar m_hWnd, SB_HORZ, Abs((m_eOrientation = efsoBoth) Or
    (m_eOrientation = efsoHorizontal))
   ShowScrollBar m_hWnd, SB_VERT, Abs((m_eOrientation = efsoBoth) Or
    (m_eOrientation = efsoVertical))
End Sub

Private Sub pGetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As
 SCROLLINFO, ByVal fMask As Long)
Dim lO As Long
    
    lO = eBar
    tSI.fMask = fMask
    tSI.cbSize = LenB(tSI)
    
    If (m_bNoFlatScrollBars) Then
        GetScrollInfo m_hWnd, lO, tSI
    Else
        FlatSB_GetScrollInfo m_hWnd, lO, tSI
    End If

End Sub
Private Sub pLetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As
 SCROLLINFO, ByVal fMask As Long)
Dim lO As Long
        
    lO = eBar
    tSI.fMask = fMask
    tSI.cbSize = LenB(tSI)
    
    If (m_bNoFlatScrollBars) Then
        SetScrollInfo m_hWnd, lO, tSI, True
    Else
        FlatSB_SetScrollInfo m_hWnd, lO, tSI, True
    End If
    
End Sub

Private Property Get Style() As EFSStyleConstants
   Style = m_eStyle
End Property
Private Property Let Style(ByVal eStyle As EFSStyleConstants)
Dim lR As Long
   If (eStyle <> efsRegular) Then
      If (m_bNoFlatScrollBars) Then
         ' can't do it..
         Debug.Print "Can't set non-regular style mode on this system -
          COMCTL32.DLL version < 4.71."
         Exit Property
      End If
   End If
   If (m_eOrientation = efsoHorizontal) Or (m_eOrientation = efsoBoth) Then
      lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_HSTYLE, eStyle, True)
   End If
   If (m_eOrientation = efsoVertical) Or (m_eOrientation = efsoBoth) Then
      lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_VSTYLE, eStyle, True)
   End If
   m_eStyle = eStyle
End Property

Private Property Get SmallChange(ByVal eBar As EFSScrollBarConstants) As Long
   If (eBar = efsHorizontal) Then
      SmallChange = m_lSmallChangeHorz
   Else
      SmallChange = m_lSmallChangeVert
   End If
End Property
Private Property Let SmallChange(ByVal eBar As EFSScrollBarConstants, ByVal
 lSmallChange As Long)
   If (eBar = efsHorizontal) Then
      m_lSmallChangeHorz = lSmallChange
   Else
      m_lSmallChangeVert = lSmallChange
   End If
End Property
Private Property Get Enabled(ByVal eBar As EFSScrollBarConstants) As Boolean
   If (eBar = efsHorizontal) Then
      Enabled = m_bEnabledHorz
   Else
      Enabled = m_bEnabledVert
   End If
End Property
Private Property Let Enabled(ByVal eBar As EFSScrollBarConstants, ByVal
 bEnabled As Boolean)
Dim lO As Long
Dim lF As Long
        
   lO = eBar
   If (bEnabled) Then
      lF = ESB_ENABLE_BOTH
   Else
      lF = ESB_DISABLE_BOTH
   End If
   If (m_bNoFlatScrollBars) Then
      EnableScrollBar m_hWnd, lO, lF
   Else
      FlatSB_EnableScrollBar m_hWnd, lO, lF
   End If
    
End Property
Private Property Get Min(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_RANGE
    Min = tSI.nMin
End Property
Private Property Get Max(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_RANGE Or SIF_PAGE
    Max = tSI.nMax - tSI.nPage
End Property
Private Property Get Value(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_POS
    Value = tSI.nPos
End Property
Private Property Get LargeChange(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_PAGE
    LargeChange = tSI.nPage
End Property
Private Property Let Min(ByVal eBar As EFSScrollBarConstants, ByVal iMin As
 Long)
Dim tSI As SCROLLINFO
    tSI.nMin = iMin
    tSI.nMax = Max(eBar) + LargeChange(eBar)
    pLetSI eBar, tSI, SIF_RANGE
End Property
Private Property Let Max(ByVal eBar As EFSScrollBarConstants, ByVal iMax As
 Long)
Dim tSI As SCROLLINFO
    tSI.nMax = iMax + LargeChange(eBar)
    tSI.nMin = Min(eBar)
    pLetSI eBar, tSI, SIF_RANGE
    pRaiseEvent eBar, False
End Property
Private Property Let Value(ByVal eBar As EFSScrollBarConstants, ByVal iValue As
 Long)
Dim tSI As SCROLLINFO
   If (iValue <> Value(eBar)) Then
      If (iValue > Max(eBar)) Then
         iValue = Max(eBar)
      ElseIf (iValue < Min(eBar)) Then
         iValue = Min(eBar)
      End If
         
      tSI.nPos = iValue
      
      pLetSI eBar, tSI, SIF_POS
      pRaiseEvent eBar, False
      
    End If
    
End Property
Private Property Let LargeChange(ByVal eBar As EFSScrollBarConstants, ByVal
 iLargeChange As Long)
Dim tSI As SCROLLINFO
Dim lCurMax As Long
Dim lCurLargeChange As Long
    
   pGetSI eBar, tSI, SIF_ALL
   tSI.nMax = tSI.nMax - tSI.nPage + iLargeChange
   tSI.nPage = iLargeChange
   pLetSI eBar, tSI, SIF_PAGE Or SIF_RANGE
   
End Property
Private Property Get CanBeFlat() As Boolean
   CanBeFlat = Not (m_bNoFlatScrollBars)
End Property
Private Sub pCreateScrollBar()
Dim lR As Long
Dim lStyle As Long
Dim hParent As Long
Dim lMajor As Long
Dim lMinor As Long
Dim isXp As Boolean

   ' Added 2003-11-26: Check for XP and above and
   ' don't use Flat Scroll bars.  They're useless
   ' under XP.
   GetWindowsVersion lMajor, lMinor
   If (lMajor > 5) Then
      isXp = True
   ElseIf (lMajor = 5) And (lMinor >= 1) Then
      isXp = True
   End If
   
   If isXp Then
      m_bNoFlatScrollBars = True
   Else
      ' Just checks for flag scroll bars...
      On Error Resume Next
      lR = InitialiseFlatSB(m_hWnd)
      If (Err.Number <> 0) Then
          'Can't find DLL entry point InitializeFlatSB in COMCTL32.DLL
          ' Means we have version prior to 4.71
          ' We get standard scroll bars.
          m_bNoFlatScrollBars = True
      Else
         Style = m_eStyle
      End If
   End If
      
End Sub

Private Sub GetWindowsVersion( _
      Optional ByRef lMajor = 0, _
      Optional ByRef lMinor = 0, _
      Optional ByRef lRevision = 0, _
      Optional ByRef lBuildNumber = 0 _
   )
Dim lR As Long
   lR = GetVersion()
   lBuildNumber = (lR And &H7F000000) \ &H1000000
   If (lR And &H80000000) Then lBuildNumber = lBuildNumber Or &H80
   lRevision = (lR And &HFF0000) \ &H10000
   lMinor = (lR And &HFF00&) \ &H100
   lMajor = (lR And &HFF)
End Sub


Private Sub Create(ByVal hWndA As Long)
   pClearUp
   m_hWnd = hWndA
   pCreateScrollBar
   pAttachMessages
End Sub

Private Sub pClearUp()
   If m_hWnd <> 0 Then
      On Error Resume Next
      ' Stop flat scroll bar if we have it:
      If Not (m_bNoFlatScrollBars) Then
         UninitializeFlatSB m_hWnd
      End If
    
      On Error GoTo 0
      ' Remove subclass:
      DetachMessage Me, m_hWnd, WM_HSCROLL
      DetachMessage Me, m_hWnd, WM_VSCROLL
      DetachMessage Me, m_hWnd, WM_MOUSEWHEEL
      DetachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
      DetachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
      DetachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
   End If
   m_hWnd = 0
   m_bInitialised = False
End Sub
Private Sub pAttachMessages()
   If (m_hWnd <> 0) Then
      AttachMessage Me, m_hWnd, WM_HSCROLL
      AttachMessage Me, m_hWnd, WM_VSCROLL
      AttachMessage Me, m_hWnd, WM_MOUSEWHEEL
      AttachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
      AttachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
      AttachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
      SystemParametersInfo SPI_GETWHEELSCROLLLINES, _
            0, m_lWheelScrollLines, 0
      If (m_lWheelScrollLines <= 0) Then
         m_lWheelScrollLines = 3
      End If
      m_bInitialised = True
   End If
End Sub

Private Sub UserControl_Initialize()
   m_lSmallChangeHorz = 1
   m_lSmallChangeVert = 1
   m_eStyle = efsRegular
   m_eOrientation = efsoBoth
   BackColor = vbWindowBackground
   GridLineColor = vbButtonShadow
   BorderStyle = esp3d
   m_hMod = LoadLibrary("shell32.dll")

End Sub

Private Sub UserControl_InitProperties()
   m_bUserMode = UserControl.Ambient.UserMode
   If (m_bUserMode) Then
      Create UserControl.hwnd
   End If
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   BackColor = PropBag.ReadProperty("BackColor", vbWindowBackground)
   BorderStyle = PropBag.ReadProperty("BorderStyle", esp3d)
   GridLineColor = PropBag.ReadProperty("GridLineColor", vbButtonShadow)
   BackgroundStyle = PropBag.ReadProperty("BackgroundStyle", espStandard)
   PictureAlign = PropBag.ReadProperty("PictureAlign", espNear)
   m_bUserMode = UserControl.Ambient.UserMode
   If (m_bUserMode) Then
      Create UserControl.hwnd
   End If
End Sub

Private Sub UserControl_Terminate()
   pClearUp
   DeleteObject m_hBmpChecker
   DeleteObject m_hBrChecker
   If Not (m_hMod = 0) Then
      FreeLibrary m_hMod
      m_hMod = 0
   End If
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   ISubclass_MsgResponse = emrPostProcess
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lScrollCode As Long
Dim tSI As SCROLLINFO
Dim lV As Long, lSC As Long
Dim eBar As EFSScrollBarConstants
Dim zDelta As Long
Dim lDelta As Long
Dim wMKeyFlags As Long

   Select Case iMsg
   Case WM_MOUSEWHEEL
      ' Low-word of wParam indicates whether virtual keys
      ' are down
      wMKeyFlags = wParam And &HFFFF&
      ' High order word is the distance the wheel has been rotated,
      ' in multiples of WHEEL_DELTA:
      If (wParam And &H8000000) Then
         ' Towards the user:
         zDelta = &H8000& - (wParam And &H7FFF0000) \ &H10000
      Else
         ' Away from the user:
         zDelta = -((wParam And &H7FFF0000) \ &H10000)
      End If
      lDelta = (zDelta \ WHEEL_DELTA) * SmallChange(efsVertical) *
       m_lWheelScrollLines
      eBar = efsVertical
      'RaiseEvent MouseWheel(eBar, lDelta)
      If Not (lDelta = 0) Then
         Value(eBar) = Value(eBar) + lDelta
         ISubclass_WindowProc = 1
      End If
   
   Case WM_VSCROLL, WM_HSCROLL
      If (iMsg = WM_HSCROLL) Then
         eBar = efsHorizontal
      Else
         eBar = efsVertical
      End If
      lScrollCode = (wParam And &HFFFF&)
      Select Case lScrollCode
      Case SB_THUMBTRACK
         ' Is vertical/horizontal?
         pGetSI eBar, tSI, SIF_TRACKPOS
         Value(eBar) = tSI.nTrackPos
         pRaiseEvent eBar, True
         
      Case SB_LEFT, SB_TOP
         Value(eBar) = Min(eBar)
         pRaiseEvent eBar, False
         
      Case SB_RIGHT, SB_BOTTOM
         Value(eBar) = Max(eBar)
         pRaiseEvent eBar, False
          
      Case SB_LINELEFT, SB_LINEUP
         'Debug.Print "Line"
         lV = Value(eBar)
         If (eBar = efsHorizontal) Then
            lSC = m_lSmallChangeHorz
         Else
            lSC = m_lSmallChangeVert
         End If
         If (lV - lSC < Min(eBar)) Then
            Value(eBar) = Min(eBar)
         Else
            Value(eBar) = lV - lSC
         End If
         pRaiseEvent eBar, False
         
      Case SB_LINERIGHT, SB_LINEDOWN
          'Debug.Print "Line"
         lV = Value(eBar)
         If (eBar = efsHorizontal) Then
            lSC = m_lSmallChangeHorz
         Else
            lSC = m_lSmallChangeVert
         End If
         If (lV + lSC > Max(eBar)) Then
            Value(eBar) = Max(eBar)
         Else
            Value(eBar) = lV + lSC
         End If
         pRaiseEvent eBar, False
          
      Case SB_PAGELEFT, SB_PAGEUP
         Value(eBar) = Value(eBar) - LargeChange(eBar)
         pRaiseEvent eBar, False
         
      Case SB_PAGERIGHT, SB_PAGEDOWN
         Value(eBar) = Value(eBar) + LargeChange(eBar)
         pRaiseEvent eBar, False
         
      Case SB_ENDSCROLL
         pRaiseEvent eBar, False
         
      End Select
      
   Case WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN
      Dim eBtn As MouseButtonConstants
      eBtn = IIf(iMsg = WM_NCLBUTTONDOWN, vbLeftButton, vbRightButton)
      If wParam = HTVSCROLL Then
         'RaiseEvent ScrollClick(efsHorizontal, eBtn)
         UserControl.SetFocus
      ElseIf wParam = HTHSCROLL Then
         'RaiseEvent ScrollClick(efsVertical, eBtn)
         UserControl.SetFocus
      End If
      
         
   End Select

End Function

Private Function pRaiseEvent(ByVal eBar As EFSScrollBarConstants, ByVal bScroll
 As Boolean)
Static s_lLastValue(0 To 1) As Long
   If (Value(eBar) <> s_lLastValue(eBar)) Then
      pPaint
      s_lLastValue(eBar) = Value(eBar)
   End If
   
End Function







Private Sub UserControl_Resize()
   pSize
   pPaint
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   PropBag.WriteProperty "BackColor", BackColor, vbWindowBackground
   PropBag.WriteProperty "BorderStyle", BorderStyle, esp3d
   PropBag.WriteProperty "GridLineColor", GridLineColor, vbButtonShadow
   PropBag.WriteProperty "BackgroundStyle", BackgroundStyle, espStandard
   PropBag.WriteProperty "PictureAlign", PictureAlign, espNear
End Sub