'// usercontrol "MonthCal"

'[To use the MonthCal class in Comctl32.dll]

'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 : MonthCal, File :MonthCal.ctl.

// FORM1;

Option Explicit

Private Sub Check1_Click()
    
    Me.MonthCal1.MonthCalStyle = mcWeek * Abs(Check1)

End Sub

Private Sub Command1_Click()

    Me.MonthCal1.MonthCalDate = CLng(Me.MonthCal1.MonthCalDate) - 1
    Label1.Caption = Me.MonthCal1.MonthCalDate

End Sub





// Usercontrol;

Option Explicit

Public Enum mcStyle

    mcNormal
    mcWeek

End Enum

Dim hmcWnd          As Long
Dim m_mcStyle       As mcStyle
Dim m_mcDate        As Date
Dim m_mcBackColor   As Long

Const def_mcStyle = mcNormal
Const def_mcBackColor = &HFFFFFF

'//////////////////////////// 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 Type RECT

    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  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 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

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 MCM_FIRST = &H1000
Const MCM_GETMINREQRECT = (MCM_FIRST + 9)
Const MCM_SETCOLOR = (MCM_FIRST + 10)

Const MCSC_BACKGROUND = 0     '// the background color (between months)
'Const MCSC_TEXT = 1           '// the dates
'Const MCSC_TITLEBK = 2        '// background of the title
'Const MCSC_TITLETEXT = 3
Const MCSC_MONTHBK = 4        '// background within the month cal
'Const MCSC_TRAILINGTEXT = 5   '// the text color of header & trailing days

Const MCM_GETCURSEL = (MCM_FIRST + 1)
Const MCM_SETCURSEL = (MCM_FIRST + 2)

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

Private Sub CreateMonthCal()

    On Error Resume Next

    Dim Dts     As Long
    Dim dStyle  As Long

    If hmcWnd Then DestroyWindow hmcWnd

    dStyle = 0

    Select Case m_mcStyle
    Case mcNormal
    Case mcWeek:    dStyle = 4
    End Select

    Dts = Dts Or dStyle

    'Create MonthCal.
    With UserControl

        hmcWnd = CreateWindowEx(0, "SysMonthCal32" _
        , "" _
        , WS_CHILD Or WS_VISIBLE Or Dts _
        , 0 _
        , 0 _
        , 0 _
        , 0 _
        , .hWnd _
        , 0 _
        , GetWindowWord(.hWnd, GWL_HINSTANCE) _
        , 0)

    End With

    SetFont
    UserControl_Resize

End Sub

Private Sub SetFont()

    If hmcWnd = 0 Then Exit Sub

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

    'Backcolor (without backcolor of calendar itself).
    SendMessage hWnd, MCM_SETCOLOR, MCSC_BACKGROUND, ByVal UserControl.BackColor

    'Backcolor of calendar part.
    SendMessage hWnd, MCM_SETCOLOR, MCSC_MONTHBK, ByVal m_mcBackColor

End Sub

Private Sub UserControl_AmbientChanged(PropertyName As String)

    SetFont

End Sub

Private Sub UserControl_InitProperties()

    On Error Resume Next

    Set Font = Ambient.Font

End Sub

Private Sub UserControl_Resize()

    On Error Resume Next

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

        .ScaleMode = vbPixels

        If hmcWnd Then

            MoveWindow hmcWnd, 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

    UserControl.BackColor = &HC0C0C0

    m_mcStyle = def_mcStyle
    m_mcBackColor = def_mcBackColor

    With Icc

        .lngSize = LenB(Icc)
        .lngICC = ICC_DATE_CLASSES

    End With

    InitCommonControlsEx Icc

    CreateMonthCal

End Sub

Public Property Get MonthCalStyle() As mcStyle

    MonthCalStyle = m_mcStyle

End Property

Public Property Let MonthCalStyle(ByVal vNewValue As mcStyle)

    On Error Resume Next

    Select Case vNewValue
    Case mcNormal, mcWeek
    Case Else: Exit Property
    End Select

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

        m_mcStyle = vNewValue

        CreateMonthCal

    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.BackColor = PropBag.ReadProperty("BackColor", &HC0C0C0)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    m_mcStyle = PropBag.ReadProperty("mcStyle", def_mcStyle)
    m_mcBackColor = PropBag.ReadProperty("mcBackColor", def_mcBackColor)

    Set Font = PropBag.ReadProperty("Font", Ambient.Font)

    CreateMonthCal
    SetFont

    m_mcDate = PropBag.ReadProperty("mcDate", Date)

    Err.Clear

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    On Error Resume Next

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HC0C0C0)
    Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("mcStyle", m_mcStyle, def_mcStyle)
    Call PropBag.WriteProperty("Font", Font, Ambient.Font)
    Call PropBag.WriteProperty("mcDate", m_mcDate, Date)
    Call PropBag.WriteProperty("mcBackColor", m_mcBackColor, def_mcBackColor)

    Err.Clear

End Sub

Public Property Get hWnd() As Long

    hWnd = hmcWnd

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 MonthCalDate() As Date

    On Error Resume Next

    If hmcWnd = 0 Then Exit Property

    Dim SysTime As SYSTEMTIME

    SendMessage hmcWnd, MCM_GETCURSEL, 0&, SysTime

    With SysTime

        MonthCalDate = DateSerial(.wYear, .wMonth, .wDay)

    End With

End Property

Public Property Let MonthCalDate(ByVal vNewValue As Date)

    On Error Resume Next

    If hmcWnd = 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 hmcWnd, MCM_SETCURSEL, 0&, SysTime

    m_mcDate = vNewValue

End Property

Public Property Get BackColor() As OLE_COLOR

    BackColor = UserControl.BackColor

End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"

    SetFont

End Property

Public Property Get BorderStyle() As Boolean

    BorderStyle = Abs(UserControl.BorderStyle) <> False

End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Boolean)

    UserControl.BorderStyle() = Abs(New_BorderStyle)
    PropertyChanged "BorderStyle"

End Property

Public Property Get ClientWidthPerCalendar() As Long

    On Error Resume Next

    If hmcWnd = 0 Then Exit Property

    Dim R As RECT

    'Request size of calendar
    SendMessage hmcWnd, MCM_GETMINREQRECT, ByVal 0&, ByVal VarPtr(R)

    ClientWidthPerCalendar = R.Right

End Property

Public Property Get ClientHeightPerCalendar() As Long

    On Error Resume Next

    If hmcWnd = 0 Then Exit Property

    Dim R As RECT

    'Request size of calendar
    SendMessage hmcWnd, MCM_GETMINREQRECT, ByVal 0&, ByVal VarPtr(R)

    ClientHeightPerCalendar = R.Bottom

End Property

Public Property Get CalBackColor() As OLE_COLOR

    CalBackColor = m_mcBackColor

End Property

Public Property Let CalBackColor(ByVal vNewValue As OLE_COLOR)

    On Error Resume Next

    If hmcWnd = 0 Then Exit Property

    m_mcBackColor = vNewValue
    SetFont

End Property