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
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 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 UserControl_Initialize()
' setup the defaults
Month = VBA.Month(Now)
Year = VBA.Year(Now)
FontName = "Arial"
FontSize = 8
BackColor = vbWhite
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.
' 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;
' 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 - 10, lHeight - 10), , B
End Sub