vbAccelerator - Contents of code file: cUpDown.ctl

VERSION 5.00
Begin VB.UserControl cUpDown 
   ClientHeight    =   495
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2685
   ControlContainer=   -1  'True
   ScaleHeight     =   495
   ScaleWidth      =   2685
   ToolboxBitmap   =   "cUpDown.ctx":0000
End
Attribute VB_Name = "cUpDown"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' ======================================================================
' Declares and types:
' ======================================================================
' Windows general:
Private Const WM_USER = &H400
Private Const WM_NOTIFY = &H4E
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
 nCmdShow As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x
 As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 bRepaint As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As
 Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As
 Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Const SW_HIDE = 0
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_BORDER = &H800000
Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const WM_GETTEXT = &HD

' Common controls general:
Private Declare Sub InitCommonControls Lib "Comctl32.dll" ()
Private Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type
Private Const CCM_FIRST = &H2000                   '// Common control shared
 messages
Private Const CCM_SETUNICODEFORMAT = (CCM_FIRST + 5)
Private Const CCM_GETUNICODEFORMAT = (CCM_FIRST + 6)
Private Const H_MAX As Long = &HFFFF + 1
Private Const UDN_FIRST = (H_MAX - 721)                   '// updown
Private Const UDN_LAST = (H_MAX - 740)


'//====== UPDOWN CONTROL =======================================================
Private Const UPDOWN_CLASSA = "msctls_updown32"
Private Const UPDOWN_CLASSW = "msctls_updown32"

#If UNICODE Then
    Private Const UPDOWN_CLASS = UPDOWN_CLASSW
#Else
    Private Const UPDOWN_CLASS = UPDOWN_CLASSA
#End If

Private Type UDACCEL
    nSec As Long
    nInc As Long
End Type

Private Const UD_MAXVAL = &H7FFF&
Private Const UD_MINVAL = (-UD_MAXVAL)

'// begin_r_commctrl

Private Const UDS_WRAP = &H1
Private Const UDS_SETBUDDYINT = &H2
Private Const UDS_ALIGNRIGHT = &H4
Private Const UDS_ALIGNLEFT = &H8
Private Const UDS_AUTOBUDDY = &H10
Private Const UDS_ARROWKEYS = &H20
Private Const UDS_HORZ = &H40
Private Const UDS_NOTHOUSANDS = &H80
'#if (_WIN32_IE >= =&H0300)
Private Const UDS_HOTTRACK = &H100
'#End If

'// end_r_commctrl

Private Const UDM_SETRANGE = (WM_USER + 101)
Private Const UDM_GETRANGE = (WM_USER + 102)
Private Const UDM_SETPOS = (WM_USER + 103)
Private Const UDM_GETPOS = (WM_USER + 104)
Private Const UDM_SETBUDDY = (WM_USER + 105)
Private Const UDM_GETBUDDY = (WM_USER + 106)
Private Const UDM_SETACCEL = (WM_USER + 107)
Private Const UDM_GETACCEL = (WM_USER + 108)
Private Const UDM_SETBASE = (WM_USER + 109)
Private Const UDM_GETBASE = (WM_USER + 110)
'#if (_WIN32_IE >= =&H0400)
Private Const UDM_SETRANGE32 = (WM_USER + 111)
Private Const UDM_GETRANGE32 = (WM_USER + 112)       '// wParam & lParam are
 LPINT
Private Const UDM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT
Private Const UDM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT
'#End If

'WINCOMMCTRLAPI HWND WINAPI CreateUpDownControl(DWORD dwStyle, int x, int y,
 int cx, int cy,
'                                HWND hParent, int nID, HINSTANCE hInst,
'                                HWND hBuddy,
'                                int nUpper, int nLower, int nPos)
Private Declare Function CreateUpDownControl Lib "COMCTL32" _
    (ByVal dwStyle As Long, _
    ByVal x As Long, ByVal y As Long, _
    ByVal cx As Long, ByVal cy As Long, _
    ByVal hParent As Long, ByVal nID As Long, ByVal hInst As Long, _
    ByVal hBuddy As Long, _
    ByVal nUpper As Long, ByVal nLower As Long, ByVal nPos As Long _
) As Long


'#if (_WIN32_IE >= =&H0300)
'Private Const NM_UPDOWN = NMUPDOWN
'Private Const LPNM_UPDOWN = LPNMUPDOWN
'#Else
'Private Const NMUPDOWN = NM_UPDOWN
'Private Const LPNMUPDOWN = LPNM_UPDOWN
'#End If

Private Type NMUPDOWN
    hdr As NMHDR
    iPos As Long
    iDelta As Long
End Type
Private Const UDN_DELTAPOS = (UDN_FIRST - 1)

'#endif  // NOUPDOWN


' ======================================================================
' Interface:
' ======================================================================
Public Enum ECUDAlignment
    udALIGNLEFT = UDS_ALIGNLEFT
    udALIGNRIGHT = UDS_ALIGNRIGHT
End Enum
Public Enum ECUDOrientation
    udVertical = 0
    udHorizontal = UDS_HORZ
End Enum
Public Enum ECUDNumberStyles
    udDecimal = 10
    udHexadecimal = 16
End Enum
Public Event BeforeChange(ByVal iPos As Long, ByRef iDelta As Long)
Public Event Change()

' ======================================================================
' Private Implementation:
' ======================================================================
Implements ISubclass
Private m_emr As EMsgResponse
Private m_bSubClassing As Boolean

Private m_hWnd As Long
Private m_bShowThousandsSeparator As Boolean
Private m_bAutoChangeBuddyText As Boolean
Private m_bAutoPositionToBuddyText As Boolean
Private m_bArrowKeysChange As Boolean
Private m_eAlignment As ECUDAlignment
Private m_eOrientation As ECUDOrientation
Private m_lUpper As Long
Private m_lLower As Long
Private m_eNumberStyle As ECUDNumberStyles
Private m_hWndBuddy As Long
Private m_lPosition As Long

Public Property Get ShowThousandsSeparator() As Boolean
    ShowThousandsSeparator = m_bShowThousandsSeparator
End Property
Public Property Let ShowThousandsSeparator(ByVal bShow As Boolean)
    If (bShow <> m_bShowThousandsSeparator) Then
        m_bShowThousandsSeparator = bShow
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "ShowThousandsSeparator"
    End If
End Property
Public Property Get AutoChangeBuddyText() As Boolean
    AutoChangeBuddyText = m_bAutoChangeBuddyText
End Property
Public Property Let AutoChangeBuddyText(ByVal bChange As Boolean)
    If (bChange <> m_bAutoChangeBuddyText) Then
        m_bAutoChangeBuddyText = bChange
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "AutoChangeBuddyText"
    End If
End Property
Public Property Get AutoPositionToBuddyText() As Boolean
    AutoPositionToBuddyText = m_bAutoPositionToBuddyText
End Property
Public Property Let AutoPositionToBuddyText(ByVal bState As Boolean)
    m_bAutoPositionToBuddyText = bState
End Property
Public Property Get ArrowKeysChange() As Boolean
    ArrowKeysChange = m_bArrowKeysChange
End Property
Public Property Let ArrowKeysChange(ByVal bChange As Boolean)
    If (bChange <> m_bArrowKeysChange) Then
        m_bArrowKeysChange = bChange
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "ArrowKeysChange"
    End If
End Property
Public Property Get Alignment() As ECUDAlignment
    Alignment = m_eAlignment
End Property
Public Property Let Alignment(ByVal eAlign As ECUDAlignment)
    If (eAlign <> m_eAlignment) Then
        m_eAlignment = eAlign
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "Alignment"
    End If
End Property
Public Property Get Orientation() As ECUDOrientation
    Orientation = m_eOrientation
End Property
Public Property Let Orientation(ByVal eOrientation As ECUDOrientation)
    If (m_eOrientation <> eOrientation) Then
        m_eOrientation = eOrientation
        If (m_hWnd <> 0) Then
            pInitialise
        End If
        PropertyChanged "Orientation"
    End If
End Property
Public Property Get NumberStyle() As ECUDNumberStyles
    NumberStyle = m_eNumberStyle
End Property
Public Property Let NumberStyle(ByVal eStyle As ECUDNumberStyles)
    If (eStyle <> m_eNumberStyle) Then
        m_eNumberStyle = eStyle
        If (m_hWnd <> 0) Then
            SendMessageLong m_hWnd, UDM_SETBASE, eStyle, 0
        End If
    End If
End Property

Public Property Get Upper() As Long
    Upper = m_lUpper
End Property
Public Property Let Upper(ByVal lUpper As Long)
    If (m_lUpper <> lUpper) Then
        m_lUpper = lUpper
        If (Abs(m_lUpper) > 32725) Then
            m_lUpper = Sgn(lUpper) * 32725
        End If
        SetRange
        PropertyChanged "Upper"
    End If
End Property
Public Property Get Lower() As Long
    Lower = m_lLower
End Property
Public Property Let Lower(ByVal lLower As Long)
    If (m_lLower <> lLower) Then
        m_lLower = lLower
        If (Abs(m_lLower) > 32725) Then
            m_lLower = Sgn(lLower) * 32725
        End If
        SetRange
        PropertyChanged "Lower"
    End If
End Property
Public Property Get Position() As Long
    If (m_hWnd <> 0) Then
        Position = (SendMessageLong(m_hWnd, UDM_GETPOS, 0, 0) And &HFFFF&)
    Else
        Position = m_lPosition
    End If
End Property
Public Property Let Position(ByVal lPos As Long)
    If (lPos <> m_lPosition) Then
        lPos = lPos And &HFFFF&
        If (m_lUpper > m_lLower) Then
            If (lPos > m_lUpper) Then
                lPos = m_lUpper
            ElseIf (lPos < m_lLower) Then
                lPos = m_lLower
            End If
        Else
            If (lPos < m_lUpper) Then
                lPos = m_lUpper
            ElseIf (lPos > m_lLower) Then
                lPos = m_lLower
            End If
        
        End If
        m_lPosition = lPos
        If (m_hWnd <> 0) Then
            SendMessageLong m_hWnd, UDM_SETPOS, 0, lPos
        End If
        PropertyChanged "Position"
    End If
End Property
Private Sub SetRange()
Dim lP As Long
    If (m_hWnd <> 0) Then
        lP = (m_lUpper And &HFFFF&) * &H10000 Or (m_lLower And &HFFFF&)
        SendMessageLong m_hWnd, UDM_SETRANGE, 0, lP
    End If

End Sub
Public Property Get hwnd() As Long
    hwnd = m_hWnd
End Property
Public Property Let BuddyhWnd(ByVal hWndA As Long)
    If (m_hWnd <> 0) Then
        SendMessageLong m_hWnd, UDM_SETBUDDY, hWndA, 0
    End If
    m_hWndBuddy = hWndA
End Property
Public Property Get BuddyhWnd() As Long
    If (m_hWnd <> 0) Then
        BuddyhWnd = SendMessageLong(m_hWnd, UDM_GETBUDDY, 0, 0)
    End If
End Property
Private Sub pInitialise()
Dim dwStyle As Long
    
    ' Ensure we don't already have UpDown control:
    pTerminate
    
    ' Ensure common controls:
    InitCommonControls
    
    ' Create the control:
    dwStyle = WS_VISIBLE Or WS_CHILD  'Or WS_BORDER
    dwStyle = dwStyle Or m_eAlignment Or m_eOrientation
    If Not (m_bShowThousandsSeparator) Then
        dwStyle = dwStyle Or UDS_NOTHOUSANDS
    End If
    If m_bAutoChangeBuddyText Then
        dwStyle = dwStyle Or UDS_SETBUDDYINT
    End If
    If m_bArrowKeysChange Then
        dwStyle = dwStyle Or UDS_ARROWKEYS
    End If
    m_hWnd = CreateUpDownControl( _
        dwStyle, _
        0, 0, UserControl.ScaleWidth \ Screen.TwipsPerPixelX,
         UserControl.ScaleHeight \ Screen.TwipsPerPixelY, _
        UserControl.hwnd, UserControl.hwnd, _
        App.hInstance, m_hWndBuddy, _
        m_lUpper, m_lLower, _
        m_lPosition)
    Debug.Assert m_hWnd <> 0
    If (m_hWnd <> 0) Then
        If (NumberStyle <> udDecimal) Then
            SendMessageLong m_hWnd, UDM_SETBASE, m_eNumberStyle, 0
        End If
        If (UserControl.Ambient.UserMode) Then
            ' Attach messages to the control:
            pAttachMessages
        End If
    End If
    
End Sub
Private Sub pAttachMessages()
    AttachMessage Me, UserControl.hwnd, WM_NOTIFY
    AttachMessage Me, UserControl.hwnd, WM_VSCROLL
    AttachMessage Me, UserControl.hwnd, WM_HSCROLL
    m_emr = emrPreprocess
    m_bSubClassing = True
End Sub
Private Sub pDetachMessages()
    If (m_bSubClassing) Then
        DetachMessage Me, UserControl.hwnd, WM_NOTIFY
        DetachMessage Me, UserControl.hwnd, WM_VSCROLL
        DetachMessage Me, UserControl.hwnd, WM_HSCROLL
        m_bSubClassing = False
    End If
End Sub
Private Sub pTerminate()
    
    If (m_hWnd <> 0) Then
        ' Stop subclassing:
        pDetachMessages
        ' Destroy the window:
        ShowWindow m_hWnd, SW_HIDE
        SetParent m_hWnd, 0
        Debug.Print DestroyWindow(m_hWnd)
        m_hWnd = 0
    End If
    
End Sub


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

Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
    ISubclass_MsgResponse = m_emr
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 tNMH As NMHDR
Dim tNMUD As NMUPDOWN
    'Process messages here:
    Select Case iMsg
    Case WM_NOTIFY
        'Debug.Print "Got WM_NOTIFY"
        CopyMemory tNMH, ByVal lParam, Len(tNMH)
        If (tNMH.idfrom = UserControl.hwnd) And (tNMH.hwndFrom = m_hWnd) Then
            If (tNMH.code = UDN_DELTAPOS) Then
                CopyMemory tNMUD, ByVal lParam, Len(tNMUD)
                pbSetFocus tNMUD.iPos
                RaiseEvent BeforeChange(tNMUD.iPos, tNMUD.iDelta)
                If (tNMUD.iDelta = 0) Then
                    ISubclass_WindowProc = 1
                End If
            End If
        End If
    Case WM_VSCROLL, WM_HSCROLL
        'Debug.Print "Got WM_nSCROLL"
        If (lParam = m_hWnd) Then
            RaiseEvent Change
        End If
    End Select
End Function
Private Function pbSetFocus(ByVal iPos As Long) As Boolean
    ' If we have a buddy control, and it is not in focus but could be, then
    ' put it into focus:
    If (m_hWndBuddy <> 0) Then
        If (IsWindowVisible(m_hWndBuddy)) Then
            If (IsWindowEnabled(m_hWndBuddy)) Then
                If Not (GetFocus() = m_hWndBuddy) Then
                    SetFocus m_hWndBuddy
                End If
            End If
        End If
    End If
End Function

Private Sub UserControl_Initialize()
    Debug.Print "cUpDown:Initialize"
    Upper = 1000
    ShowThousandsSeparator = True
    Alignment = udALIGNRIGHT
    Orientation = udVertical
    NumberStyle = udDecimal
    ArrowKeysChange = True
End Sub

Private Sub UserControl_InitProperties()
    pInitialise
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Lower = PropBag.ReadProperty("Lower", 0)
    Upper = PropBag.ReadProperty("Upper", 1000)
    Position = PropBag.ReadProperty("Position", 0)
    Orientation = PropBag.ReadProperty("Orientation", udVertical)
    Alignment = PropBag.ReadProperty("Alignment", udALIGNRIGHT)
    ShowThousandsSeparator = PropBag.ReadProperty("ShowThousandsSeparator",
     True)
    NumberStyle = PropBag.ReadProperty("NumberStyle", udDecimal)
    ArrowKeysChange = PropBag.ReadProperty("ArrowKeysChange", True)
    AutoChangeBuddyText = PropBag.ReadProperty("AutoChangeBuddyText", False)
    pInitialise
End Sub

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

Private Sub UserControl_Terminate()
    pTerminate
    Debug.Print "cUpDown:Terminate"
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Lower", Lower, 0
    PropBag.WriteProperty "Upper", Upper, 1000
    PropBag.WriteProperty "Position", Position, 0
    PropBag.WriteProperty "Orientation", Orientation, udVertical
    PropBag.WriteProperty "Alignment", Alignment, udALIGNRIGHT
    PropBag.WriteProperty "ShowThousandsSeparator", ShowThousandsSeparator, True
    PropBag.WriteProperty "NumberStyle", NumberStyle, udDecimal
    PropBag.WriteProperty "ArrowKeysChange", ArrowKeysChange, True
    PropBag.WriteProperty "AutoChangeBuddyText", AutoChangeBuddyText, False
    pTerminate
End Sub