Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/csdtpckr/cscal.ctl

Visual Basic Form | 1998-10-31 | 20.5 KB | 509 lines

VERSION 5.00
Begin VB.UserControl CSCal
   ClientHeight    =   315
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1275
   ScaleHeight     =   21
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   85
   ToolboxBitmap   =   "CSCal.ctx":0000
Attribute VB_Name = "CSCal"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
' Written By: Bob Walker
'             [e-mail]
' For       : Computer Simple, Inc.
'             www.computersimple.com
' Constants needed
Private Const DATETIMEPICK_CLASS = "SysDateTimePick32"
Private Const ICC_DATE_CLASSES = &H100&
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const GDTR_MIN = 1&
Private Const GDTR_MAX = 2&
Private Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)
Private Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2)
Private Const DTM_GETRANGE = (DTM_FIRST + 3)
Private Const DTM_SETRANGE = (DTM_FIRST + 4)
Private Const DTM_SETFORMAT = (DTM_FIRST + 5)
Private Const DTM_SETMCCOLOR = (DTM_FIRST + 6)
Private Const DTM_GETMCCOLOR = (DTM_FIRST + 7)
Private Const DTM_SETMCFONT = (DTM_FIRST + 9)
Private Const DTM_GETMCFONT = (DTM_FIRST + 10)
Private Const DTS_UPDOWN = &H1&            '// use UPDOWN instead of MONTHCAL
Private Const DTS_SHOWNONE = &H2&          '// allow a NONE selection
Private Const DTS_SHORTDATEFORMAT = &H0&   '// use the short date format (app must forward WM_WININICHANGE messages)
Private Const DTS_LONGDATEFORMAT = &H4&    '// use the long date format (app must forward WM_WININICHANGE messages)
Private Const DTS_TIMEFORMAT = &H9&        '// use the time format (app must forward WM_WININICHANGE messages)
Private Const DTS_APPCANPARSE = &H10&      '// allow user entered strings (app MUST respond to DTN_USERSTRING)
Private Const DTS_RIGHTALIGN = &H20&       '// right-align popup instead of left-align it
Private Const MCSC_TEXT = 1&         '   // the dates
Private Const MCSC_TITLEBK = 2&      '   // background of the title and the text day names
Private Const MCSC_TITLETEXT = 3&    '   // text of the date string in the title
Private Const MCSC_MONTHBK = 4&      '   // background within the month cal
Private Const MCSC_TRAILINGTEXT = 5& '   // the text color of header & trailing days
Private Type ICCE
    lSize As Long
    lICC As Long
End Type
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As ICCE) As Boolean
Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
'Default Property Values:
Const m_def_Value = 0
Const m_def_Min = Empty
Const m_def_Max = Empty
Const m_def_UpDown = False
Const m_def_AlignRight = False
Const m_def_TimePick = False
Const m_def_FDOW = vbUseSystemDayOfWeek
Const m_def_ShowToday = False
Const m_def_ShowWeeks = False
Const m_def_BackColor = SystemColorConstants.vbWindowBackground
Const m_def_TextColor = SystemColorConstants.vbWindowText
Const m_def_TitleBackColor = SystemColorConstants.vbActiveTitleBar
Const m_def_TitleTextColor = SystemColorConstants.vbTitleBarText
Const m_def_TrailTextColor = SystemColorConstants.vbGrayText
'Property Variables:
Dim m_Value As Date
Dim m_Min As Variant
Dim m_Max As Variant
Dim m_UpDown As Boolean
Dim m_AlignRight As Boolean
Dim m_TimePick As Boolean
Dim m_FDOW As VbDayOfWeek
Dim m_ShowToday As Boolean
Dim m_ShowWeeks As Boolean
Dim m_BackColor As OLE_COLOR
Dim m_TextColor As OLE_COLOR
Dim m_TitleBackColor As OLE_COLOR
Dim m_TitleTextColor As OLE_COLOR
Dim m_TrailTextColor As OLE_COLOR
Dim m_hWnd As Long ' Stores the handle to the DatePicker
Dim m_hWndProc As Long ' Stores the handle to the window subclass process
Dim m_hWndUCProc As Long ' Stores the handle to the user control subclass process
Public Event Change()
Attribute Change.VB_Description = "Event raised when the Value has been changed."
' The HWnd??? properties are hidden, for use by
' the subclassed routines. They cannot be declared
' friend properties because the object reference kept in
' the collection could not access them as such.
Public Property Let HWndValue(ByVal New_Value As Date)
Attribute HWndValue.VB_MemberFlags = "40"
    If CanPropertyChange("Value") Then
        m_Value = New_Value
        PropertyChanged "Value"
        RaiseEvent Change
    End If
End Property
Public Property Get HWndProc() As Long
Attribute HWndProc.VB_MemberFlags = "40"
    HWndProc = m_hWndProc
End Property
Public Property Get HWndUCProc() As Long
Attribute HWndUCProc.VB_MemberFlags = "40"
    HWndUCProc = m_hWndUCProc
End Property
Public Property Get hwnd() As Long
Attribute hwnd.VB_UserMemId = -515
Attribute hwnd.VB_MemberFlags = "40"
    hwnd = UserControl.hwnd
End Property
Public Property Get HWndDP() As Long
Attribute HWndDP.VB_MemberFlags = "40"
    HWndDP = m_hWnd
End Property
Private Sub UserControl_GotFocus()
    ' Move the focus into the textbox portion of the
    ' date/time picker when the control receives focus
    If m_hWnd <> 0 Then apiSetFocus m_hWnd
End Sub
Private Sub UserControl_Initialize()
    Dim iccex As ICCE
    With iccex
        .lSize = LenB(iccex)
        .lICC = ICC_DATE_CLASSES
    End With
    InitCommonControlsEx iccex
End Sub
Private Sub UserControl_InitProperties()
    Set UserControl.Font = Ambient.Font
    m_BackColor = m_def_BackColor
    m_TextColor = m_def_TextColor
    m_TitleBackColor = m_def_TitleBackColor
    m_TitleTextColor = m_def_TitleTextColor
    m_TrailTextColor = m_def_TrailTextColor
    m_Min = m_def_Min
    m_Max = m_def_Max
    m_UpDown = m_def_UpDown
    m_AlignRight = m_def_AlignRight
    m_TimePick = m_def_TimePick
    m_FDOW = m_def_FDOW
    m_ShowToday = m_def_ShowToday
    m_ShowWeeks = m_def_ShowWeeks
    m_Value = m_def_Value
    ' Only SubClass when in Run Mode, otherwise it'll crash
    ' because the ChangeWinProc() isn't available (not running)
    If Ambient.UserMode = True Then
        'SubClass UserControl.hWnd
        scCollection.Add Me, "H" & Hex(hwnd)
        m_hWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ChangeWinProc)
    End If
    Create
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    m_TextColor = PropBag.ReadProperty("TextColor", m_def_TextColor)
    m_TitleBackColor = PropBag.ReadProperty("TitleBackColor", m_def_TitleBackColor)
    m_TitleTextColor = PropBag.ReadProperty("TitleTextColor", m_def_TitleTextColor)
    m_TrailTextColor = PropBag.ReadProperty("TrailTextColor", m_def_TrailTextColor)
    m_Min = PropBag.ReadProperty("Min", m_def_Min)
    m_Max = PropBag.ReadProperty("Max", m_def_Max)
    m_UpDown = PropBag.ReadProperty("UpDown", m_def_UpDown)
    m_AlignRight = PropBag.ReadProperty("AlignRight", m_def_AlignRight)
    m_TimePick = PropBag.ReadProperty("TimePick", m_def_TimePick)
    m_FDOW = PropBag.ReadProperty("FDOW", m_def_FDOW)
    m_ShowToday = PropBag.ReadProperty("ShowToday", m_def_ShowToday)
    m_ShowWeeks = PropBag.ReadProperty("ShowWeeks", m_def_ShowWeeks)
    m_Value = PropBag.ReadProperty("Value", m_def_Value)

    ' Only SubClass when in Run Mode, othewise it'll crash
    ' because the ChangeWinProc() isn't available (not running)
    If Ambient.UserMode = True Then
        'SubClass UserControl.hWnd
        scCollection.Add Me, "H" & Hex(hwnd)
        m_hWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ChangeWinProc)
    End If

    Create
End Sub
Private Sub UserControl_Resize()
    ' Whenever the user control is resized,
    ' re-create the window to fit the new size
    Create
End Sub
Private Sub UserControl_Terminate()
    If m_hWndProc <> 0 Then
        ' UnSubclass
        SetWindowLong hwnd, GWL_WNDPROC, m_hWndProc
        scCollection.Remove "H" & Hex(hwnd)
    End If
    Destroy
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Determines whether focus and user input are accepted by the control."
    Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    Create
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Determine the font used in displaying the textbox and the dropdown."
    Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
    Create
End Property
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Font", Font, Ambient.Font)
    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("TextColor", m_TextColor, m_def_TextColor)
    Call PropBag.WriteProperty("TitleBackColor", m_TitleBackColor, m_def_TitleBackColor)
    Call PropBag.WriteProperty("TitleTextColor", m_TitleTextColor, m_def_TitleTextColor)
    Call PropBag.WriteProperty("TrailTextColor", m_TrailTextColor, m_def_TrailTextColor)
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
    Call PropBag.WriteProperty("UpDown", m_UpDown, m_def_UpDown)
    Call PropBag.WriteProperty("AlignRight", m_AlignRight, m_def_AlignRight)
    Call PropBag.WriteProperty("TimePick", m_TimePick, m_def_TimePick)
    Call PropBag.WriteProperty("FDOW", m_FDOW, m_def_FDOW)
    Call PropBag.WriteProperty("ShowToday", m_ShowToday, m_def_ShowToday)
    Call PropBag.WriteProperty("ShowWeeks", m_ShowWeeks, m_def_ShowWeeks)
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
End Sub
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "The background color used for the dropdown."
    BackColor = m_BackColor
End Property
Public Property Let BackColor(ByVal New_Color As OLE_COLOR)
    m_BackColor = New_Color
    PropertyChanged "BackColor"
    If m_hWnd = 0 Then
        Create
    Else
        SendMessage m_hWnd, DTM_SETMCCOLOR, _
            MCSC_MONTHBK, ByVal OleColor(BackColor)
    End If
End Property
Public Property Get TextColor() As OLE_COLOR
Attribute TextColor.VB_Description = "Color of the text used to display the dates for the current month."
    TextColor = m_TextColor
End Property
Public Property Let TextColor(ByVal New_Color As OLE_COLOR)
    m_TextColor = New_Color
    PropertyChanged "TextColor"
    If m_hWnd = 0 Then
        Create
    Else
        SendMessage m_hWnd, DTM_SETMCCOLOR, _
            MCSC_TEXT, ByVal OleColor(TextColor)
    End If
End Property
Public Property Get TitleBackColor() As OLE_COLOR
Attribute TitleBackColor.VB_Description = "Color of the background displayed in the dropdown title bar."
    TitleBackColor = m_TitleBackColor
End Property
Public Property Let TitleBackColor(ByVal New_Color As OLE_COLOR)
    m_TitleBackColor = New_Color
    PropertyChanged "TitleBackColor"
    If m_hWnd = 0 Then
        Create
    Else
        SendMessage m_hWnd, DTM_SETMCCOLOR, _
            MCSC_TITLEBK, ByVal OleColor(TitleBackColor)
    End If
End Property
Public Property Get TitleTextColor() As OLE_COLOR
Attribute TitleTextColor.VB_Description = "Color of the font used to display the month/year at the top of the dropdown."
    TitleTextColor = m_TitleTextColor
End Property
Public Property Let TitleTextColor(ByVal New_Color As OLE_COLOR)
    m_TitleTextColor = New_Color
    PropertyChanged "TitleTextColor"
    If m_hWnd = 0 Then
        Create
    Else
        SendMessage m_hWnd, DTM_SETMCCOLOR, _
            MCSC_TITLETEXT, ByVal OleColor(TitleTextColor)
    End If
End Property
Public Property Get TrailTextColor() As OLE_COLOR
Attribute TrailTextColor.VB_Description = "Color of the font used to display the leading and trailing dates from the prior/next month in the dropdown."
    TrailTextColor = m_TrailTextColor
End Property
Public Property Let TrailTextColor(ByVal New_Color As OLE_COLOR)
    m_TrailTextColor = New_Color
    PropertyChanged "TrailTextColor"
    If m_hWnd = 0 Then
        Create
    Else
        SendMessage m_hWnd, DTM_SETMCCOLOR, _
            MCSC_TRAILINGTEXT, ByVal OleColor(TrailTextColor)
    End If
End Property
Public Property Get Min() As Variant
Attribute Min.VB_Description = "Set/get the Lowest date/time value selectable by the user."
    Min = m_Min
End Property
Public Property Let Min(ByVal New_Min As Variant)
    Dim stRange(0 To 1) As SYSTEMTIME
    m_Min = IIf(IsDate(New_Min), New_Min, Empty)
    PropertyChanged "Min"
    If m_hWnd = 0 Then
        Create
    Else
        If Not IsEmpty(m_Min) Then
            SetDate m_Min, stRange(0)
            SendMessage m_hWnd, DTM_SETRANGE, GDTR_MIN, stRange(0)
        End If
    End If
End Property
Public Property Get Max() As Variant
Attribute Max.VB_Description = "Set/Get the highest date/time value selectable by the user."
    Max = m_Max
End Property
Public Property Let Max(ByVal New_Max As Variant)
    Dim stRange(0 To 1) As SYSTEMTIME
    m_Max = IIf(IsDate(New_Max), New_Max, Empty)
    PropertyChanged "Max"
    If m_hWnd = 0 Then
        Create
    Else
        If Not IsEmpty(m_Max) Then
            SetDate m_Max, stRange(1)
            SendMessage m_hWnd, DTM_SETRANGE, GDTR_MAX, stRange(0)
        End If
    End If
End Property
Public Property Get UpDown() As Boolean
Attribute UpDown.VB_Description = "If true, displays an UpDown control on the right edge of the textbox and allow the user to spin/edit the value."
    UpDown = m_UpDown
End Property
Public Property Let UpDown(ByVal New_UpDown As Boolean)
    m_UpDown = New_UpDown
    PropertyChanged "UpDown"
    Create
End Property
Public Property Get AlignRight() As Boolean
Attribute AlignRight.VB_Description = "Determine whether to display the dropdown aligned to the right edge of the control, or the left."
    AlignRight = m_AlignRight
End Property
Public Property Let AlignRight(ByVal New_AlignRight As Boolean)
    m_AlignRight = New_AlignRight
    PropertyChanged "AlignRight"
    Create
End Property
Public Property Get TimePick() As Boolean
Attribute TimePick.VB_Description = "Determine whether the control will be used to pick times or dates."
    TimePick = m_TimePick
End Property
Public Property Let TimePick(ByVal New_Value As Boolean)
    m_TimePick = New_Value
    PropertyChanged "TimePick"
    Create
End Property
Public Property Get FirstDayOfWeek() As VbDayOfWeek
Attribute FirstDayOfWeek.VB_Description = "Determine the order of the days of week displayed on the dropdown."
    FirstDayOfWeek = m_FDOW
End Property
Public Property Let FirstDayOfWeek(ByVal New_Value As VbDayOfWeek)
    m_FDOW = New_Value
    PropertyChanged "FDOW"
End Property
Public Property Get ShowToday() As Boolean
Attribute ShowToday.VB_Description = "Determine whether to display the today date and circle today's date on the dropdown calendar."
    ShowToday = m_ShowToday
End Property
Public Property Let ShowToday(ByVal New_Value As Boolean)
    m_ShowToday = New_Value
    PropertyChanged "ShowToday"
End Property
Public Property Get ShowWeeks() As Boolean
Attribute ShowWeeks.VB_Description = "Determine whether to display the week numbers alongside the dropdown month calendar."
    ShowWeeks = m_ShowWeeks
End Property
Public Property Let ShowWeeks(ByVal New_Value As Boolean)
    m_ShowWeeks = New_Value
    PropertyChanged "ShowWeeks"
End Property
' The method used to create the date picker(s) from the API
' calls, based on the various customized settings
Private Function Create() As Boolean
    Dim fTemp As IFont
    Dim stRange(0 To 1) As SYSTEMTIME
    Dim stDateTime As SYSTEMTIME
    Dim stFlags As Long
    If m_hWnd <> 0 Then Destroy
    m_hWnd = CreateWindowEX(0, DATETIMEPICK_CLASS, "DateTime", _
         (WS_CHILD Or WS_VISIBLE Or Abs(UpDown) Or IIf(Enabled, 0, WS_DISABLED)) Or _
         (IIf(AlignRight, DTS_RIGHTALIGN, 0) Or IIf(TimePick, DTS_TIMEFORMAT, 0)), _
          0&, 0&, ScaleWidth, ScaleHeight, _
          UserControl.hwnd, 0&, App.hInstance, ByVal 0&)
    ' Set to the saved date value
    SetDate m_Value, stDateTime
    SendMessage m_hWnd, DTM_SETSYSTEMTIME, 0&, stDateTime
    ' Change Colors
    '   the dates
    SendMessage m_hWnd, DTM_SETMCCOLOR, _
        MCSC_TEXT, ByVal OleColor(TextColor)

    '   background of the title
    SendMessage m_hWnd, DTM_SETMCCOLOR, _
        MCSC_TITLEBK, ByVal OleColor(TitleBackColor)

    SendMessage m_hWnd, DTM_SETMCCOLOR, _
        MCSC_TITLETEXT, ByVal OleColor(TitleTextColor)

    '   background within the month cal
    SendMessage m_hWnd, DTM_SETMCCOLOR, _
        MCSC_MONTHBK, ByVal OleColor(BackColor)

    '   the text color of header & trailing days
    SendMessage m_hWnd, DTM_SETMCCOLOR, _
        MCSC_TRAILINGTEXT, ByVal OleColor(TrailTextColor)
    ' Convert/Set Font
    '   need to convert to an IFont to obtain the hFont
    '   property used to set a calendar font.
    Set fTemp = Font
    SendMessage m_hWnd, WM_SETFONT, _
        fTemp.hFont, ByVal False
    SendMessage m_hWnd, DTM_SETMCFONT, _
        fTemp.hFont, ByVal False
    ' Set Min/Max Range
    stFlags = 0
    If Not IsEmpty(Min) Then
        SetDate Min, stRange(0)
        stFlags = GDTR_MIN
    End If
    If Not IsEmpty(Max) Then
        SetDate Max, stRange(1)
        stFlags = stFlags + GDTR_MAX
    End If
    If stFlags > 0 Then
        SendMessage m_hWnd, DTM_SETRANGE, stFlags, stRange(0)
    End If
    'SubClass Only in run mode.
    If Ambient.UserMode = True Then
        scCollection.Add Me, "U" & Hex(m_hWnd)
        m_hWndUCProc = SetWindowLong(m_hWnd, GWL_WNDPROC, AddressOf ToggleWinProc)
    Else
        m_hWndUCProc = 0
    End If
    ShowWindow m_hWnd, SW_SHOWNORMAL
End Function
' Method used to destroy the created control(s).
Private Function Destroy() As Boolean
    ' UnSubClass
    If m_hWndUCProc <> 0 Then
        scCollection.Remove "U" & Hex(m_hWnd)
        SetWindowLong m_hWnd, GWL_WNDPROC, m_hWndUCProc
        m_hWndUCProc = 0
    End If
    If m_hWnd <> 0 Then DestroyWindow m_hWnd
    m_hWnd = 0
End Function
' Value returns Empty if either the date is not valid,
' or if the date has not yet been set. Otherwise return
' the date/time portion of the value the user selected.
Public Property Get Value() As Variant
Attribute Value.VB_Description = "The value property is used to get/set the current date/time displayed in the control."
Attribute Value.VB_UserMemId = 0
Attribute Value.VB_MemberFlags = "23c"
    If Not IsDate(m_Value) Then
        Value = Empty
    ElseIf m_Value = m_def_Value Then
        Value = Empty
    Else
        If TimePick Then
            Value = TimeValue(m_Value)
        Else
            Value = DateValue(m_Value)
        End If
    End If
End Property
Public Property Let Value(ByVal New_Value As Variant)
    Dim stDateTime As SYSTEMTIME
    If CanPropertyChange("Value") Then
        If m_hWnd = 0 Then Exit Property

        If Not IsDate(New_Value) Then New_Value = m_def_Value
        m_Value = New_Value

        ' Defaults to today
        SetDate m_Value, stDateTime

        SendMessage m_hWnd, DTM_SETSYSTEMTIME, 0&, stDateTime

        PropertyChanged "Value"
        RaiseEvent Change

    End If
End Property