View Code Snippet

Author: Nathan Hobbs
Date Submitted: 6/6/2007
Category: Custom Controls
Compatibility: VB 6,VB 5,VB 4/32,VB 4/16,VB 3
This code has been accessed 3201 times.

Task: Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable. Written from Scratch. (Inspired by another VBCode item which was very bloated!)

Declarations

Code

Private Sub Form_Paint() 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