Excel Custom Calendar Control

Question

I'm developing my own Excel Custom Calendar Control based on AccessWorld - Calendar because there is not an ActiveX calendar available on some of the computers that use my workbooks. I was able to replicate most of the functionality except for changing the Calendar date using the keyboard arrows.

The Calendar consist of two classes: CalendarClass and DayLabelClass. In order to create the calendar you will need to instantiate a class level CalendarClass variable and pass a MsForms.Frame to its Init method. The CalendarClass will add all the necessary controls to the MsForms.Frame and sizes them to fit.

CalendarClass

This class is responsible for setting up the controls and raising a Change event when its Value is changed.

Option Explicit
Private Const LEFTPAD As Single = 8
Private WithEvents CalFrame As MSForms.Frame
Private ParentFrame As MSForms.Frame
Private DayLabels(0 To 5, 0 To 6) As DayLabelClass
Private WithEvents lblHighlighter As MSForms.Label
Private WithEvents MonthScroll As MSForms.ScrollBar
Private WeekDayLabels(7) As DayLabelClass
Private WithEvents MonthCombo As MSForms.ComboBox
Private WithEvents YearScroll As MSForms.ScrollBar
Private WithEvents YearTextBox As MSForms.TextBox
Private mValue As Date

Public Event Change(CalDate As Date)

Sub Init(ParentFrame1 As MSForms.Frame)
    Set ParentFrame = ParentFrame1
    ParentFrame.Caption = ""
    Set CalFrame = ParentFrame.Add("Forms.Frame.1", , True)
    With CalFrame
        .BorderStyle = fmBorderStyleNone
        .BackColor = vbWhite
        .Caption = ""
        .Height = 150
        .Width = 130.25
    End With

    AddDateControls
    AddWeekdayLabels 10, 30
    AddDayLabels 10, 38
    AddHighLighter
    AutoFit
    Value = Date
End Sub

Function Controls() As MSForms.Controls
    Set Controls = CalFrame.Controls
End Function

Private Sub HiglightDate(DayLabel As MSForms.Label)
    With lblHighlighter
        .Top = DayLabel.Top - 8
        .Left = DayLabel.Left - 4
    End With
End Sub

Private Sub AddDayLabels(Left As Single, Top As Single)
    Dim x As Long, y As Long
    For x = 0 To 5
        For y = 0 To 6
            Set DayLabels(x, y) = New DayLabelClass
            DayLabels(x, y).Init Me, x, y, Left, Top + LEFTPAD
        Next
    Next
End Sub

Sub AddWeekdayLabels(Left As Single, Top As Single)
    Dim x As Long, y As Long
    Dim text As String

    For y = 0 To 7
        Set WeekDayLabels(y) = New DayLabelClass

        With WeekDayLabels(y)
            .Init Me, x, y, Left, Top
            If y < 7 Then
                .Caption = Choose(y + 1, "Su", "Mo", "Tu", "We", "Th", "Fr", "Sa")
            Else
                .Init Me, 0, 0, Left, Top + 10
                With .getLabel
                    .Height = 2
                    .BackColor = vbBlue
                    .BorderStyle = fmBorderStyleSingle
                    .Width = WeekDayLabels(6).getLabel.Left + WeekDayLabels(6).getLabel.Width - LEFTPAD
                End With
            End If
        End With
    Next
End Sub

Private Sub AddDateControls()
    Const Top = 10
    Set MonthScroll = Controls.Add("Forms.ScrollBar.1", , True)

    With MonthScroll
        .Left = LEFTPAD
        .Height = 16
        .Top = Top
        .Width = 55
        .Orientation = fmOrientationHorizontal
        .ZOrder (0.2)
        .Value = 2
    End With

    Set MonthCombo = Controls.Add("Forms.ComboBox.1", , True)

    With MonthCombo
        .Left = MonthScroll.Left + 14
        .Height = 16
        .Top = Top
        .Width = 30
        .ListWidth = 60
        .ListRows = 12
        .ShowDropButtonWhen = fmShowDropButtonWhenFocus
        .ZOrder (0.3)
        .List = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    End With

    Set YearScroll = Controls.Add("Forms.ScrollBar.1", , True)

    With YearScroll
        .Left = MonthScroll.Left + 2 + MonthScroll.Width
        .Height = 16
        .Top = Top
        .Width = 53
        .Orientation = fmOrientationHorizontal
        .ZOrder (0.2)
        .Value = 2
    End With

    Set YearTextBox = Controls.Add("Forms.TextBox.1", , True)

    With YearTextBox
        .Locked = True
        .Left = YearScroll.Left + 14
        .Height = 16
        .Top = Top
        .Width = 28
        .ZOrder (0.3)
    End With
End Sub

Private Sub AddHighLighter()
    Set lblHighlighter = Controls.Add("Forms.Label.1", , True)

    With lblHighlighter
        .BackStyle = fmBackStyleTransparent
        .Font = "Wingdings"
        .Caption = Chr(82)
        .Font.Size = 26
        .ForeColor = vbRed
        .Height = 26
        .Width = 26
        .ZOrder (1)
    End With
End Sub

Public Sub AutoFit()
    Dim BottomCal As Single, Zoom As Integer

    With CalFrame
        BottomCal = .Top + .Height
        Zoom = ParentFrame.Height / BottomCal * 100
        .Left = (ParentFrame.Width - (.Width * (Zoom / 100))) / 2.4
    End With

    With ParentFrame
        .Zoom = Zoom
    End With

End Sub

Public Property Get Value() As Date
    Value = mValue
End Property

Public Property Let Value(ByVal DateOf As Date)
    Dim iDayOffset As Integer, x As Long, y As Long
    Dim FirstCalDate As Date, FirstDayOfMonth As Date
    mValue = DateOf

    FirstDayOfMonth = mValue - Day(mValue) + 1

    FirstCalDate = FirstDayOfMonth + vbSunday - Weekday(FirstDayOfMonth, vbSunday)

    For x = 0 To 5
        For y = 0 To 6
            With DayLabels(x, y)
                iDayOffset = (x * 7) + y
                .Value = FirstCalDate + iDayOffset
                If .Value = Value Then HiglightDate .getLabel
            End With
        Next
    Next

    YearTextBox.text = Year(Value)
    MonthCombo.ListIndex = Month(Value) - 1

    RaiseEvent Change(Value)
End Property

Private Sub MonthCombo_Change()
    Value = DateSerial(YearTextBox.Value, MonthCombo.ListIndex + 1, Day(Value))
    SendKeys "{TAB}" ' Change focus from the MonthCombo, so that the dropdown will hide
End Sub

Private Sub MonthScroll_Change()
    With MonthScroll
        If .Value <> 2 Then
            Value = DateAdd("m", .Value - 2, Value)
            .Value = 2
        End If
    End With
    SendKeys "{TAB}" ' Change focus from the MonthCombo, so that the dropdown will hide
End Sub

Private Sub YearScroll_Change()
    With YearScroll
        If .Value <> 2 Then
            Value = DateAdd("yyyy", .Value - 2, Value)
            .Value = 2
        End If
    End With
End Sub

DayLabelClass

The DayLabelClass wraps an MsForms.Label that displays its day value. When the label is clicked the DayLabelClass updates the CalendarClass's Value.

Option Explicit
Private WithEvents DayLabel As MSForms.Label
Private mCalendar As CalendarClass
Private Const Width As Single = 15.75
Private Const Height As Single = 15.75
Private mValue As Date

Sub Init(Calendar1 As CalendarClass, x As Long, y As Long, Left As Single, Top As Single)
    Set mCalendar = Calendar1
    Set DayLabel = mCalendar.Controls.Add("Forms.Label.1", , True)
    With DayLabel
        .Left = (Width * y) + Left
        .Top = (Height * x) + Top
        .Width = Width
        .Height = Height
        .BackStyle = fmBackStyleTransparent
        .TextAlign = fmTextAlignCenter
    End With
End Sub

Private Sub DayLabel_Click()
    mCalendar.Value = Value
End Sub

Public Property Get Value() As Date
    Value = mValue
End Property

Public Property Let Value(ByVal DateOf As Date)
    mValue = DateOf
    DayLabel.Caption = Day(Value)
End Property

Public Property Get Caption() As String
    Caption = DayLabel.Caption
End Property

Public Property Let Caption(ByVal Caption1 As String)
    DayLabel.Caption = Caption1
End Property

Public Function getLabel() As MSForms.Label
    Set getLabel = DayLabel
End Function

In the future I may add an alternate init routine that will allow the CalendarClass to act like a DatePicker control by linking it to a Textbox and only having it show when the Textbox has focus. I might even go crazy and add some comments.

Answer 1

I like it. I only have comments on one aspect -

Your SpinButtons are unclear.

You have two procedures for each (set of) buttons - SpinDown and SpinUp. But they look like this -

Private Sub SpinHeight_SpinDown()

Compare that to AutoFit -

Private Sub btnAutoFitCalendar_Click()

It took me a little while to figure out that those were referring to the Spin Buttons.

These seem notoriously difficult to find reference for - I didn't even know what they were called

I'd change the names to indicate they are buttons. Also, I'm not sure they are the right control to be using. From the reference above

Is this the right control?

To decide, consider these questions:

• Is the control used for numeric input? If not, use another control, such as a drop-down list or slider, to select from a fixed set of values. Use scroll bars for scrolling.
• Do users think of the value as a relative quantity, not a numeric value? If so, use a slider instead. Use spin boxes only for exact, known numeric values. For example, users think about setting their audio volume to low or medium—not about setting the value to 2 or 5.
• Is the control paired with a text box? If not, don't use. Spin controls shouldn't be used alone or with other types of controls besides a text box.

In addition, your Height spinbutton seems upside down. Click left or right on Width and it goes that way. Click up or down on Height and it goes opposite.

You also run into problems using them and then trying to AutoFit -

It might make more sense to allow users to resize the window. I made it backwards compatible for 64-bit by making it safe to use pointers.

Private Const WS_THICKFRAME As Long = &H40000
Private Const GWL_STYLE As Long = -16

Private Declare PtrSafe Function GetForegroundWindow Lib "User32.dll" () As LongPtr

Private Declare PtrSafe Function GetWindowLong Lib "User32.dll" Alias     "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As
LongPtr) As LongPtr

Private Declare PtrSafe Function SetWindowLong Lib "User32.dll" Alias  
"SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As
LongPtr, ByVal dwNewLong As LongPtr) As LongPtr


Public Sub MakeFormResizable()

  Dim lStyle As LongPtr
  Dim hWnd As LongPtr
  Dim RetVal

    hWnd = GetForegroundWindow

    'Get the basic window style
     lStyle = GetWindowLong(hWnd, GWL_STYLE) Or WS_THICKFRAME

    'Set the basic window styles
     RetVal = SetWindowLong(hWnd, GWL_STYLE, lStyle)

End Sub

This way you can also restrict the size of the frame relative to the size of the window so you don't get the error on the .zoom property. You can keep the zoom at 100 and resize your parentframe and calframe based on one another. (Which I don't have an example of)