• 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. 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 #




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

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

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