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.