by Nathan Hobbs (2 Submissions)
Category: Custom Controls/Forms/Menus
Compatability: Visual Basic 3.0
Difficulty: Unknown Difficulty
Originally Published: Wed 6th June 2007
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. Written from Scratch. (Inspired by another
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! #
Dim CurrentDate As Date, DatePos(1 To 6, 1 To 7) As Date
VBcoders
DrawCalendar
End Sub
Sub DrawCalendar()
If CurrentDate = "00:00:00" Then CurrentDate = Date
' 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
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") > 10
.FontSize = .FontSize * 1.5
Loop
.FontSize = .FontSize / 1.5
.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
Private Sub MyCal_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
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 Else: CurrentDate = DatePos(Int((Y - 10) / 10), Int(X / 10) + 1) ' Clicked on a date
End Select
DrawCalendar ' Reflact changes
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..
