Create a new user control and paste this code into it. Call the user control ucCalendar.
If you have any questions, email us at help@codeoftheweek.com
'----------------------------------------------------------------------
'
' Module Name: ucCalendar
' Written By: C&D Programming Corp.
' Create Date: 6/2000
' Copyright: Copyright 2000 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'
'----------------------------------------------------------------------
Option Explicit
Private mlMonth As Long ' local variable to store the displayed month
Private mlYear As Long ' local variable to store the displayed year
' had to make this public in order to use it in typRange
' if you add any new commands, make sure you call AddRangeCheck
' to define the range on the calendar grid for the command you add.
' Also be sure to add code to MouseClickCheck to perform the action
' you require for the new command.
' as you can see this calendar is now very easy to extend to include
' things like highlighting certain days, clicking on a day to show
' details for a particular day, etc. These have not yet been
' implemented, but could be without too much additional effort.
' A future COTW issue might expand this.
Public Enum CalendarCommand
ccNextMonth = 100
ccPreviousMonth = 101
ccNextYear = 102
ccPreviousYear = 103
ccSelectMonth = 104
End Enum
Private Enum Direction
dirLeft
dirRight
End Enum
Private Type typRange
Command As CalendarCommand
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private maClickRanges() As typRange
Public Property Let BackColor(lBackColor As Long)
UserControl.BackColor = lBackColor
RedrawCalendar
End Property
Public Property Let FontName(sFontName As String)
On Error Resume Next
UserControl.FontName = sFontName
RedrawCalendar
End Property
Public Property Get FontName() As String
FontName = UserControl.FontName
End Property
Public Property Let FontSize(lFontSize As Long)
UserControl.FontSize = lFontSize
RedrawCalendar
End Property
Public Property Get FontSize() As Long
FontSize = UserControl.FontSize
End Property
Public Property Let Month(lMonth As Long)
mlMonth = lMonth
RedrawCalendar
End Property
Public Property Get Month() As Long
Month = mlMonth
End Property
Public Property Let Year(lYear As Long)
mlYear = lYear
RedrawCalendar
End Property
Public Property Get Year() As Long
Year = mlYear
End Property
Public Sub NextYear()
Year = Year + 1
End Sub
Public Sub PreviousYear()
Year = Year - 1
End Sub
Public Sub NextMonth()
' calculate the next month to display based on the current settings
If Month = 12 Then
Month = 1
Year = Year + 1
Else
Month = Month + 1
End If
End Sub
Public Sub PreviousMonth()
' calculate the previous month to display based on the current settings
If Month = 1 Then
Month = 12
Year = Year - 1
Else
Month = Month - 1
End If
End Sub
' calculate the number of days in each month
Private Property Get NumberOfDays() As Long
Select Case Me.Month
Case 1, 3, 5, 7, 8, 10, 12
NumberOfDays = 31
Case 4, 6, 9, 11
NumberOfDays = 30
Case 2
' trick to determine leap years. Take March 1 of the currently
' shown year and subtract 1 to determine the last day in
' February.
NumberOfDays = Day(CDate("3/1/" & Me.Year) - 1)
End Select
End Property
Private Sub lstMonth_Click()
Month = lstMonth.ListIndex + 1
lstMonth.Visible = False
End Sub
Private Sub UserControl_Initialize()
' setup the defaults
Dim x As Long
Month = VBA.Month(Now)
Year = VBA.Year(Now)
FontName = "Arial"
FontSize = 8
BackColor = vbWhite
For x = 1 To 12
lstMonth.AddItem Format(x & "/1/2000", "mmmm")
Next
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
CheckMouseClick x, y
End Sub
Private Sub UserControl_Paint()
RedrawCalendar
End Sub
Public Sub RedrawCalendar()
Dim lWidth As Long
Dim lHeight As Long
Dim x As Long
Dim lDayCount As Long ' number of days in a week
Dim lWeekCount As Long ' number of weeks to show in the grid
Dim lDayNum As Long ' counter variable to loop through the days
Dim lCellWidth As Long ' width of a day cell
Dim lCellHeight As Long ' height of a day cell
Dim lStartDay As Long ' weekday to start the month with
Dim lColumn As Long ' which column we are currently in when
' drawing the days
Dim lRow As Long ' the row
Dim lDayWidth As Long ' width of the day text
Dim sDay As String ' name of the weekday (such as Mon, Tue)
Dim sMonth As String ' name of the month.
' erase all the range clicks
Erase maClickRanges
UserControl.ScaleMode = vbPixels
' perform some initial calculations to determine various
' heights and widths of the cells.
lWidth = UserControl.ScaleWidth
lHeight = UserControl.ScaleHeight
lDayCount = 7
lWeekCount = 7
lCellWidth = lWidth / lDayCount
lCellHeight = lHeight / lWeekCount
' clear calendar
Line (UserControl.ScaleLeft, UserControl.ScaleTop)-(lWidth - 10, lHeight - 10), vbWhite, BF
' draw day separators. We use lCellHeight because we do not need to
' draw the lines into the top portion of the first row (where the month
' and names of the days go).
For x = 1 To lDayCount - 1
Line (x * (lWidth / lDayCount), lCellHeight)-(x * (lWidth / lDayCount), lHeight), , BF
Next
' draw week separators - do not draw into the first row
For x = 2 To lWeekCount - 1
Line (0, x * (lHeight / lWeekCount))-(lWidth, x * (lHeight / lWeekCount)), , BF
Next
' fill in day numbers
lStartDay = WeekDay(CDate(Me.Month & "/1/" & Me.Year))
lColumn = lStartDay - 1
lRow = 1
For lDayNum = 1 To NumberOfDays
' put numbers in the upper left of each cell.
' we can use centering logic here as shown below for each day
UserControl.CurrentX = lColumn * lCellWidth
UserControl.CurrentY = lRow * lCellHeight
UserControl.Print lDayNum;
lColumn = lColumn + 1
' if we hit the last column, wrap back around to the
' first column.
If lColumn >= lDayCount Then
lColumn = 0
lRow = lRow + 1
End If
Next
' fill in day headings
Line (UserControl.ScaleLeft, UserControl.ScaleTop)-(lCellWidth * lDayCount, lCellHeight), vbButtonFace, BF
Line (UserControl.ScaleLeft, UserControl.ScaleTop)-(lCellWidth * lDayCount, lCellHeight), , B
' draw month centered using the language that the format command returns.
UserControl.CurrentY = 0
sMonth = Format$(CDate(CDate(Month & "/1/" & Year)), "mmmm yyyy")
UserControl.CurrentX = (UserControl.ScaleWidth - UserControl.TextWidth(sMonth)) / 2
UserControl.Print sMonth;
' add a range check to allow for showing a month listing upon clicking the month.
AddRangeCheck ccSelectMonth, lCellWidth, 0, UserControl.ScaleWidth - lCellWidth, lCellHeight / 2
' vertical boxes for moving the calendar by month and year
DrawSmallBox 0, lCellWidth, lCellHeight, vbAlignLeft, ccPreviousYear
DrawSmallBox 0, lCellWidth, lCellHeight, vbAlignRight, ccPreviousMonth
DrawSmallBox 6, lCellWidth, lCellHeight, vbAlignLeft, ccNextMonth
DrawSmallBox 6, lCellWidth, lCellHeight, vbAlignRight, ccNextYear
' fill in the names of the days along the top of the grid
For lDayNum = 0 To 6
' names go on the bottom half of the first row.
UserControl.CurrentY = lCellHeight / 2
' we use 7/2/2000 because we know this is a sunday. This will
' allow us to have a language independent calendar
sDay = Format$(CDate(CDate("7/2/2000") + lDayNum), "ddd")
lDayWidth = UserControl.TextWidth(sDay)
'Debug.Print sDay, lDayWidth
' This allows us to center the day names within each day.
UserControl.CurrentX = lDayNum * lCellWidth + ((lCellWidth - lDayWidth) / 2)
UserControl.Print sDay;
Next
' draw border around entire calendar
Line (ScaleLeft, ScaleTop)-(lWidth - 1, lHeight - 1), , B
End Sub
'
' This routine handles the drawing of the navigation boxes used for
' moving the calendar by month and year
'
Private Sub DrawSmallBox(lColumn As Long, lCellWidth As Long, lCellHeight As Long, _
lJustify As AlignConstants, eCommand As CalendarCommand)
Dim lHorizOffset As Long
Dim lVertOffset As Long
Dim lTop As Long ' top
Dim lLeft As Long ' left
Dim lBottom As Long
Dim lRight As Long
' decide on the justification. currently it always aligns the box along the
' top portion of a cell. All small boxes are drawn 1/2 the height of a day
' cell.
Select Case lJustify
Case vbAlignLeft
lHorizOffset = lColumn * lCellWidth
Case vbAlignRight
lHorizOffset = lColumn * lCellWidth + (lCellWidth / 2)
End Select
' figure out the dimensions of the box to draw.
lTop = 0
lLeft = lHorizOffset
lRight = lHorizOffset + lCellWidth / 2
lBottom = lCellHeight / 2
' draw the box
Line (lLeft, lTop)-(lRight, lBottom), , B
' add a range to check to handle the click events.
AddRangeCheck eCommand, lLeft, lTop, lRight, lBottom
' call the drawarrows routine to draw the indicator for the
' end user to understand what is going to change. it draws
' a < to move one month earlier, a << to move one year earlier
' a > to move one month later and a >> to move one year later.
Select Case eCommand
Case ccNextMonth
DrawArrows lLeft, lTop, lRight, lBottom, dirRight
Case ccNextYear
DrawArrows lLeft - 2, lTop, lRight - 2, lBottom, dirRight
DrawArrows lLeft + 2, lTop, lRight + 2, lBottom, dirRight
Case ccPreviousMonth
DrawArrows lLeft, lTop, lRight, lBottom, dirLeft
Case ccPreviousYear
DrawArrows lLeft - 2, lTop, lRight - 2, lBottom, dirLeft
DrawArrows lLeft + 2, lTop, lRight + 2, lBottom, dirLeft
End Select
End Sub
'
' does the actual drawing of arrows within a "small box" as described above.
' the eDirection controls whether the arrows are pointing to the left or
' to the right.
'
Private Sub DrawArrows(lLeft As Long, lTop As Long, lRight As Long, _
lBottom As Long, eDirection As Direction)
Dim lWidth As Long
Dim lHeight As Long
lWidth = lRight - lLeft
lHeight = lBottom - lTop
Select Case eDirection
Case dirLeft
Line (CLng(lRight - lWidth / 3), CLng(lTop + lHeight / 4))-(CLng(lLeft + (lWidth / 3)), CLng(lHeight / 2))
Line (CLng(lLeft + (lWidth / 3)), CLng(lHeight / 2))-(CLng(lRight - lWidth / 3), CLng(lBottom - (lHeight / 4)))
Case dirRight
Line (CLng(lLeft + lWidth / 3), CLng(lTop + lHeight / 4))-(CLng(lLeft + (lWidth / 3) * 2), CLng(lHeight / 2))
Line (CLng(lLeft + (lWidth / 3) * 2), CLng(lHeight / 2))-(CLng(lLeft + lWidth / 3), CLng(lBottom - (lHeight / 4)))
End Select
End Sub
'
' handles the array used to store the mouse clicking ranges that
' perform some sort of action.
'
Private Sub AddRangeCheck(cmd As CalendarCommand, lLeft As Long, lTop As Long, lRight As Long, lBottom As Long)
Dim lTopRange As Long
On Error Resume Next
' check to see if any elements have been added yet to the range array
lTopRange = UBound(maClickRanges)
If Err Then ' none yet defined so make new index a 1.
lTopRange = 1
Else
lTopRange = lTopRange + 1
End If
' redim the array to handle new ranges. This is not the most
' efficient method, but for the number of elements we are adding
' the time should be pretty minimal.
ReDim Preserve maClickRanges(lTopRange)
' set the properties
With maClickRanges(lTopRange)
.Command = cmd
.Left = lLeft
.Top = lTop
.Right = lRight
.Bottom = lBottom
End With
End Sub
'
' Here is where all the fun stuff occurs when a mouse click is received.
' This routine scans the range array to determine if the mouse click
' has fallen within any of the predefined locations on the calendar
' grid. Note that we handle all the commands that are defined in the
' CalendarCommand enumerator.
'
Private Function CheckMouseClick(x As Single, y As Single)
Dim lIndex As Long
' let's just hide this in case the user clicked somplace else
lstMonth.Visible = False
For lIndex = LBound(maClickRanges) To UBound(maClickRanges)
' check the click position to see if it falls within a predefined box.
If ((x >= maClickRanges(lIndex).Left) And (x <= maClickRanges(lIndex).Right)) And _
((y >= maClickRanges(lIndex).Top) And (y <= maClickRanges(lIndex).Bottom)) Then
' perform the action required. An interesting enhancement here
' might be to right an event with the appropriate command. This
' could give your application a chance to provide additional
' functionality as commands are executed. On example of this
' might be to update another control showing data for the
' newly selected month or year.
Select Case maClickRanges(lIndex).Command
Case ccPreviousMonth
PreviousMonth
Case ccNextMonth
NextMonth
Case ccPreviousYear
PreviousYear
Case ccNextYear
NextYear
Case ccSelectMonth
' position listbox and display
lstMonth.Top = maClickRanges(lIndex).Bottom
lstMonth.Left = maClickRanges(lIndex).Left
lstMonth.Width = maClickRanges(lIndex).Right - lstMonth.Left
lstMonth.Height = UserControl.ScaleHeight - maClickRanges(lIndex).Bottom
lstMonth.ListIndex = Month - 1
lstMonth.Visible = True
End Select
End If
Next
End Function