• Home
 · 
• Custom Controls/Forms/Menus
 · 
• Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable.

Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable.

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



Rate Code to use a PictureBox as a calendar. Virtually no code! No OCXs needed. Resizable. Reformatable.

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

    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