by Nathan Hobbs (2 Submissions)
Category: Custom Controls/Forms/Menus
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Sat 9th February 2008
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable. This is an updated version of my earlier
API Declarations
' # Drop a PictureBox onto the form and call it MyCal #
' # Set CurrentDate to the date you want and call DrawCalendar #
' # Call DrawCalendar again at any time to refresh it #
' # This Code is Copyright (C) Nathan Hobbs 2007 #
' # You are free to do what you wish with this code #
' # as long as you give appropriate credit to the #
' # author for the original code... seems only fair! #
' # Note: There are no actual declarations in this version #
VBcoders
Sub DrawCalendar(MyCal As PictureBox)
If MyCal.ToolTipText = "" Then MyCal.ToolTipText = Date
Dim CurrentDate As Date: CurrentDate = CDate(MyCal.ToolTipText)
MyCal.Visible = True
' Store dates
Dim FirstDate As Date: FirstDate = DateSerial(Year(CurrentDate), Month(CurrentDate), 1)
Dim GoFrom As Date: GoFrom = IIf(Weekday(FirstDate) = 1, FirstDate - 7, FirstDate - Weekday(FirstDate) + 1)
Dim DateLoop As Date, Row As Long: Row = 1
Dim DatePos(1 To 6, 1 To 7) As Date
For DateLoop = GoFrom To GoFrom + 41
DatePos(Row, Weekday(DateLoop)) = DateLoop
If Weekday(DateLoop) = 7 Then Row = Row + 1
Next DateLoop
With MyCal
.Cls
MyCal.Scale (0, 0)-(70, 90)
' Define font sizes/colors
Do While Not .TextWidth("XoX") > 9
.FontSize = .FontSize * 1.1
Loop
.FontSize = .FontSize / 1.1
.FontBold = True
.ForeColor = &H404040
' Write headers
MyCal.Line (0, 0)-(70, 18), &HE0E0E0, BF
MyCal.Line (0, 78)-(70, 90), &HE0E0E0, BF
Dim titlewidth As Long: titlewidth = .TextWidth(Format(CurrentDate, "mmmm yyyy"))
.CurrentY = 0: .CurrentX = ((50 - titlewidth) / 2) + 10: MyCal.Print Format(CurrentDate, "mmmm yyyy")
.CurrentY = 0: .CurrentX = 3: MyCal.Print "<<"
.CurrentY = 0: .CurrentX = 63: MyCal.Print ">>"
.CurrentY = 80: .CurrentX = (70 - .TextWidth("[Go to today...]")) / 2: MyCal.Print "[Go to today...]"
' Write days of week mon, tue etc
For X = 0 To 6
.CurrentY = 10: .CurrentX = (10 - .TextWidth(Format(#1/29/1978# + X, "ddd"))) / 2 + (10 * X): MyCal.Print Format(#1/29/1978# + X, "ddd")
Next X
' Loop through stored dates and write to screen
Dim RowLoop As Long, ColLoop As Long, dt As Date
For RowLoop = 1 To 6
For ColLoop = 1 To 7
dt = DatePos(RowLoop, ColLoop) ' store date for quick access
.CurrentY = (RowLoop + 1) * 10
.CurrentX = ((ColLoop - 1) * 10) + (10 - .TextWidth(Day(dt))) / 2
.ForeColor = vbBlack ' write as black as default
If Format(dt, "mmmyy") <> Format(CurrentDate, "mmmyy") Then .ForeColor = &H808080 ' use grey for next and previous months
If dt = CurrentDate Then .ForeColor = vbRed ' use red for selected date
If dt = CurrentDate Then .FontBold = True Else .FontBold = False ' use bold for selected date
MyCal.Print Day(dt) ' print the number to the screen
Next ColLoop
Next RowLoop
End With
End Sub
Sub TrackCalendar(MyCal As PictureBox, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim CurrentDate As Date: CurrentDate = CDate(MyCal.ToolTipText)
' Store dates
Dim FirstDate As Date: FirstDate = DateSerial(Year(CurrentDate), Month(CurrentDate), 1)
Dim GoFrom As Date: GoFrom = IIf(Weekday(FirstDate) = 1, FirstDate - 7, FirstDate - Weekday(FirstDate) + 1)
Dim DateLoop As Date, Row As Long: Row = 1
Dim DatePos(1 To 6, 1 To 7) As Date
For DateLoop = GoFrom To GoFrom + 41
DatePos(Row, Weekday(DateLoop)) = DateLoop
If Weekday(DateLoop) = 7 Then Row = Row + 1
Next DateLoop
Select Case True
Case Y < 20 And Y > 10: Exit Sub ' Cilcked on Mon, Tue etc - do nothing
Case Y > 80: CurrentDate = Date ' Clicked on "Go to today"
Case Y < 10 And X > 60 And X < 70: CurrentDate = DateAdd("m", 1, CurrentDate) ' Go forward a month
Case Y < 10 And X > 0 And X < 10: CurrentDate = DateAdd("m", -1, CurrentDate) ' Go abck a month
Case Y < 10
Case Else
If Format(DatePos(Int((Y - 10) / 10), Int(X / 10) + 1), "mmmyy") = Format(CurrentDate, "mmmyy") Then ' Clicked on a date
CurrentDate = DatePos(Int((Y - 10) / 10), Int(X / 10) + 1)
Else
CurrentDate = DatePos(Int((Y - 10) / 10), Int(X / 10) + 1)
End If
End Select
MyCal.ToolTipText = Format(CurrentDate, "dd-mmm-yy")
Frm_SelectData.Controls(MyCal.Tag).Text = CurrentDate
DrawCalendar MyCal ' Reflact changes
End Sub
Private Sub PicDate_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
TrackCalendar PicDate, Button, Shift, X, Y
End Sub
No comments have been posted about Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable.. Why not be the first to post a comment about Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable..
