'[To use the datetimepicker in Comctl32.dll]
'The original was from Ben Baird (See original.txt)

'This procedure is not quite ready yet,
'i won't make any changes from here but,
'who likes to take over?

'For suggestions,
'E.B. Knoppert, ProFinance WOERDEN Netherlands
'ebknoppert@hotmail.com

'Code/Example below is identical to the VB6 project.
'Code should be pasted into Form1 and usercontrol : Datepicker, File :DateTime.ctl.

'// usercontrol "Datepicker"

Option Explicit

Public Enum dpDateFormat

    dpShortDate
    dpLongDate
    dpTime

End Enum

Public Enum dpStyle

    dpDownbutton
    dpUpDownbutton
    dpCheckbox      'HOW to read status?? (Hint : Use enabled API)

End Enum

Dim hdpWnd          As Long
Dim m_DateFormat    As dpDateFormat
Dim m_dpStyle       As dpStyle
Dim m_dpDate        As Date

Const def_DateFormat = dpShortDate
Const def_dpStyle = dpDownbutton

'//////////////////////////// API ////////////////////////////////

Private Type SYSTEMTIME

     wYear          As Integer
     wMonth         As Integer
     wDayOfWeek     As Integer
     wDay           As Integer
     wHour          As Integer
     wMinute        As Integer
     wSecond        As Integer
     wMilliseconds  As Integer

End Type

Private Type tagInitCommonControlsEx

     lngSize    As Long
     lngICC     As Long

End Type

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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowWord Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Integer
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long

Const DTM_FIRST = &H1000
Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)
Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2)
Const DTS_LONGDATEFORMAT = &H4
Const DTS_SHORTDATEFORMAT = &H0
Const DTS_TIMEFORMAT = &H9
Const GWL_HINSTANCE = (-6)
Const ICC_DATE_CLASSES = &H100&
Const WM_GETFONT = &H31
Const WM_SETFONT = &H30
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WM_KEYDOWN = &H100
Const VK_F4 = &H73

'/////////////////////////// Usercontrol //////////////////////

Private Sub CreateDatePicker()

    On Error Resume Next

    Dim Dts As Long
    Dim dStyle As Long

    If hdpWnd Then DestroyWindow hdpWnd

    'Set default date format.
    Dts = DTS_SHORTDATEFORMAT

    Select Case m_DateFormat
    Case dpShortDate
    Case dpLongDate:    Dts = DTS_LONGDATEFORMAT
    Case dpTime:        Dts = DTS_TIMEFORMAT
    End Select

    'Buttonstyle
    dStyle = dpDownbutton

    Select Case m_dpStyle
    Case dpDownbutton
    Case dpUpDownbutton:    dStyle = 1
    Case dpCheckbox:        dStyle = 2
    End Select

    Dts = Dts Or m_dpStyle

    'Create datepicker.
    With UserControl

        .ScaleMode = vbPixels

        hdpWnd = CreateWindowEx(0, "SysDateTimePick32" _
        , "" _
        , WS_CHILD Or WS_VISIBLE Or Dts _
        , 0 _
        , 0 _
        , .ScaleWidth _
        , .ScaleHeight _
        , .hWnd _
        , 0 _
        , GetWindowWord(.hWnd, GWL_HINSTANCE) _
        , 0)

    End With

End Sub

Private Sub SetFont()

    If hdpWnd = 0 Then Exit Sub

    'Set same font as usercontrol.
    SendMessage hdpWnd, WM_SETFONT, SendMessage(UserControl.hWnd, WM_GETFONT, 0, 0), True

End Sub

Private Sub UserControl_AmbientChanged(PropertyName As String)

    SetFont

End Sub

Private Sub UserControl_GotFocus()

    'If usercontrol gets focus, set focus to calendar.
    If hdpWnd And UserControl.Enabled Then SetFocusAPI hdpWnd

End Sub

Private Sub UserControl_InitProperties()

    On Error Resume Next

    Set Font = Ambient.Font

End Sub

Private Sub UserControl_Resize()

    On Error Resume Next

    'Datepicker should be the same size as the usercontrol.
    With UserControl

        If hdpWnd Then

            MoveWindow hdpWnd, 0, 0, .ScaleWidth, .ScaleHeight, -1

        End If

    End With

End Sub

Private Sub UserControl_Initialize()

    On Error Resume Next

    'Initialize and call InitCommonControlsEx to enable DLL.
    Dim Icc As tagInitCommonControlsEx

    m_DateFormat = def_DateFormat
    m_dpStyle = def_dpStyle

    With Icc

        .lngSize = LenB(Icc)
        .lngICC = ICC_DATE_CLASSES

    End With

    InitCommonControlsEx Icc

    CreateDatePicker

End Sub

Public Property Get DatePickerFormat() As dpDateFormat

    DatePickerFormat = m_DateFormat

End Property

Public Property Let DatePickerFormat(ByVal vNewValue As dpDateFormat)

    On Error Resume Next

    Select Case vNewValue
    Case dpShortDate, dpLongDate, dpTime
    Case Else: Exit Property
    End Select

    'New type of format is specified, the current DP is destroyed and recreated again!
    If m_DateFormat <> vNewValue Then

        m_DateFormat = vNewValue

        CreateDatePicker

    End If

End Property

Public Property Get DatePickerStyle() As dpStyle

    DatePickerStyle = m_dpStyle

End Property

Public Property Let DatePickerStyle(ByVal vNewValue As dpStyle)

    On Error Resume Next

    Select Case vNewValue
    Case dpDownbutton, dpUpDownbutton, dpCheckbox
    Case Else: Exit Property
    End Select

    'New type of style is specified, the current DP is destroyed and recreated again!
    If m_dpStyle <> vNewValue Then

        m_dpStyle = vNewValue

        CreateDatePicker

    End If

End Property

Public Property Get Enabled() As Boolean

    Enabled = UserControl.Enabled

End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)

    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"

End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    On Error Resume Next

    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    m_DateFormat = PropBag.ReadProperty("DateFormat", def_DateFormat)
    m_dpStyle = PropBag.ReadProperty("dpStyle", def_dpStyle)
    Set Font = PropBag.ReadProperty("Font", Ambient.Font)

    CreateDatePicker
    SetFont

    m_dpDate = PropBag.ReadProperty("dpDate", Date)

    Err.Clear

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    On Error Resume Next

    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("DateFormat", m_DateFormat, def_DateFormat)
    Call PropBag.WriteProperty("dpStyle", m_dpStyle, def_dpStyle)
    Call PropBag.WriteProperty("Font", Font, Ambient.Font)
    Call PropBag.WriteProperty("dpDate", m_dpDate, Date)

    Err.Clear

End Sub

Public Property Get hWnd() As Long

    hWnd = hdpWnd

End Property

Public Property Get Font() As Font

    On Error Resume Next

    Set Font = UserControl.Font

End Property

Public Property Set Font(ByVal New_Font As Font)

    On Error Resume Next

    Set UserControl.Font = New_Font
    PropertyChanged "Font"
    SetFont

End Property

Public Property Get DatePickerDate() As Date

    On Error Resume Next

    If hdpWnd = 0 Then Exit Property

    Dim a As Long
    Dim Text As String

    Text = String$(255, 32)

    a = GetWindowText(hdpWnd, Text, Len(Text))

    m_dpDate = CVDate(Left$(Text, a))

    DatePickerDate = m_dpDate

End Property

Public Property Let DatePickerDate(ByVal vNewValue As Date)

    On Error Resume Next

    If hdpWnd = 0 Then Exit Property

    Dim SysTime As SYSTEMTIME

    With SysTime

        .wYear = Year(vNewValue)
        .wMonth = Month(vNewValue)
        .wDay = Day(vNewValue)
        .wHour = Hour(vNewValue)
        .wMinute = Minute(vNewValue)
        .wSecond = Second(vNewValue)

    End With

    SendMessage hdpWnd, DTM_SETSYSTEMTIME, 0&, SysTime
    m_dpDate = vNewValue

End Property

Sub ToggleCalendar()

    On Error Resume Next

    If hdpWnd = 0 Then Exit Sub

    SendMessage hdpWnd, WM_KEYDOWN, VK_F4, ByVal 0&

End Sub

'// Form1

Option Explicit

Private Sub Command1_Click()

    'You are able to show the calendar part with having the combo visible.
    'This makes it possible to use an other control as "calendarbox".

    'Be sure the invisble combo has the same height and width as the button.
    With Me.Command1

        Me.DatePicker2.Move .Left, .Top, .Width, .Height

    End With


    'Enable calendar and set date in caption..
    With Me.DatePicker2

        .DatePickerDate = Me.DatePicker1.DatePickerDate

        .ToggleCalendar

        Me.Command1.Caption = .DatePickerDate

    End With

End Sub

