VB.Net - Date Picker User Control
Note
When adding this control to your form, you should either use the name Ctl_Date or rename the class to match
the name you selected.
A Date Picker Control
The 4 buttons at the top of the control increment the week, day, month and year. The 4 buttons at the bottom decrease the week, day, month and year.
Option Strict On
Option Explicit On
Imports System.ComponentModel
Public Class Ctl_Date
Private _Date As Date = Midday(Now)
Private _MinDate As Date = Midday(_Date.AddYears(-5))
Private _MaxDate As Date = Midday(_Date.AddYears(5))
Private _Font As New Font(Me.Font.Name, 18, Me.Font.Style)
Private _BtnColour As Color = Button.DefaultBackColor
Private _CtlBackColour As Color = Control.DefaultBackColor
Private _TextForeColour As Color = Color.Black
Private _TextBackColour As Color = Color.FromArgb(255, 255, 255, 207)
Private butU(3) As Button
Private lab(3) As Label
Private butD(3) As Button
Private Control_Is_Ready As Boolean = False
Private Prev_Date As Date = _Date
Event Date_Changed()
Private Sub Ctl_Date_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.Enabled = False
DrawControls()
Control_Is_Ready = True
' control_is_ready - during initial load, invalid dates are possible
' this flag ensures ctl has finished loading and has a valid date
ShowDate()
Me.Enabled = True
End Sub
Private Sub DrawControls()
Dim nam() As String = {"Www", "Dd", "Mmm", "Yyyy"}
Dim LabWidth(3) As Integer
Dim LabHeight As Integer
Dim ButHeight As Integer
Dim siz As Size = TextRenderer.MeasureText("WWW ", _Font)
LabWidth(0) = siz.Width
LabHeight = siz.Height
siz = TextRenderer.MeasureText("28 ", _Font)
LabWidth(1) = siz.Width
siz = TextRenderer.MeasureText("MMM ", _Font)
LabWidth(2) = siz.Width
siz = TextRenderer.MeasureText("2888 ", _Font)
LabWidth(3) = siz.Width
ButHeight = CInt(Math.Ceiling(LabHeight / 4))
If ButHeight < 4 Then ButHeight = 4
Dim w, h As Integer
For i As Integer = 0 To 3
Dim l As Integer
butU(i) = New Button
lab(i) = New Label
butD(i) = New Button
Select Case i
Case 0
l = ButHeight
lab(i).Text = _Date.ToString("ddd")
Case 1
l = butU(0).Left + butU(0).Width + ButHeight
lab(i).Text = _Date.Day.ToString
Case 2
l = butU(1).Left + butU(1).Width + ButHeight
lab(i).Text = _Date.ToString("MMM")
Case 3
l = butU(2).Left + butU(2).Width + ButHeight
lab(i).Text = _Date.ToString("yyyy")
End Select
butU(i).Location = New Point(l, ButHeight)
butU(i).AutoSize = False
butU(i).Size = New Size(LabWidth(0), ButHeight)
butU(i).BackColor = SystemColors.ButtonShadow
butU(i).Font = New Font(_Font.Name, 6, _Font.Style)
butU(i).Name = "But" & nam(i) & "U"
butU(i).Text = String.Empty
butU(i).ForeColor = Color.Black
butU(i).FlatStyle = FlatStyle.Flat
lab(i).Location = New Point(l, ButHeight * 2 + 2)
lab(i).Size = New Size(LabWidth(0), LabHeight)
lab(i).AutoSize = False
lab(i).BackColor = _TextBackColour
lab(i).BorderStyle = BorderStyle.FixedSingle
lab(i).Font = _Font
lab(i).ForeColor = _TextForeColour
lab(i).Name = "Lab" & nam(i)
lab(i).TextAlign = Drawing.ContentAlignment.MiddleCenter
butD(i).Location = New Point(l, ButHeight * 2 + lab(0).Height + 4)
butD(i).AutoSize = False
butD(i).Size = New Size(LabWidth(0), ButHeight)
butD(i).BackColor = SystemColors.ButtonShadow
butD(i).Font = New Font(_Font.Name, 6, _Font.Style)
butD(i).Name = "But" & nam(i) & "D"
butD(i).Text = String.Empty
butD(i).ForeColor = Color.Black
butD(i).FlatStyle = FlatStyle.Flat
AddHandler butU(i).Click, AddressOf Button_Click
AddHandler butD(i).Click, AddressOf Button_Click
Me.Controls.Add(butU(i))
Me.Controls.Add(lab(i))
Me.Controls.Add(butD(i))
Next
w = butD(3).Left + butD(3).Width + ButHeight
h = butD(3).Top + (2 * butD(3).Height)
Me.BackColor = _CtlBackColour
Me.BorderStyle = BorderStyle.FixedSingle
Me.Size = New Size(w, h)
End Sub
Private Function Midday(dat As Date) As Date
Return New Date(dat.Year, dat.Month, dat.Day, 12, 0, 0, 0, 0)
End Function
Private Sub Button_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
Select Case CType(sender, Button).Name.ToString
Case "ButWwwU" : _Date = _Date.AddDays(7)
Case "ButDdU" : _Date = _Date.AddDays(1)
Case "ButMmmU" : _Date = _Date.AddMonths(1)
Case "ButYyyyU" : _Date = _Date.AddYears(1)
Case "ButWwwD" : _Date = _Date.AddDays(-7)
Case "ButDdD" : _Date = _Date.AddDays(-1)
Case "ButMmmD" : _Date = _Date.AddMonths(-1)
Case "ButYyyyD" : _Date = _Date.AddYears(-1)
End Select
If _Date < _MinDate Then _Date = _MinDate
If _Date > _MaxDate Then _Date = _MaxDate
ShowDate()
End Sub
Private Sub ShowDate()
If Not Control_Is_Ready Then Exit Sub
lab(0).Text = _Date.ToString("ddd")
lab(1).Text = _Date.Day.ToString
lab(2).Text = _Date.ToString("MMM")
lab(3).Text = _Date.Year.ToString
For i As Integer = 0 To 3
butU(i).Visible = _Date < _MaxDate
butD(i).Visible = _Date > _MinDate
Next
If _Date <> Prev_Date Then
Prev_Date = _Date
RaiseEvent Date_Changed()
End If
End Sub
Private Sub ResizeAll()
Dim LabWidth(3) As Integer
Dim LabHeight As Integer
Dim ButHeight As Integer
Dim siz As Size = TextRenderer.MeasureText("WWW ", _Font)
LabWidth(0) = siz.Width
LabHeight = siz.Height
siz = TextRenderer.MeasureText("28 ", _Font)
LabWidth(1) = siz.Width
siz = TextRenderer.MeasureText("MMM ", _Font)
LabWidth(2) = siz.Width
siz = TextRenderer.MeasureText("2888 ", _Font)
LabWidth(3) = siz.Width
ButHeight = CInt(Math.Ceiling(LabHeight / 4))
If ButHeight < 4 Then ButHeight = 4
Dim w, h As Integer
For i As Integer = 0 To 3
Dim l As Integer
Select Case i
Case 0
l = ButHeight
Case 1
l = butU(0).Left + butU(0).Width + ButHeight
Case 2
l = butU(1).Left + butU(1).Width + ButHeight
Case 3
l = butU(2).Left + butU(2).Width + ButHeight
End Select
butU(i).Location = New Point(l, ButHeight)
butU(i).Size = New Size(LabWidth(0), ButHeight)
lab(i).Location = New Point(l, ButHeight * 2 + 2)
lab(i).Size = New Size(LabWidth(0), LabHeight)
lab(i).Font = _Font
butD(i).Location = New Point(l, ButHeight * 2 + lab(0).Height + 4)
butD(i).Size = New Size(LabWidth(0), ButHeight)
Next
w = butD(3).Left + butD(3).Width + ButHeight
h = butD(3).Top + (2 * butD(3).Height)
Me.BackColor = _CtlBackColour
Me.BorderStyle = BorderStyle.FixedSingle
Me.Size = New Size(w, h)
End Sub
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_Date As Date
Get
Return _Date
End Get
Set(value As Date)
Dim v As Date = Midday(value)
If v < _MinDate Then v = _MinDate
If v > _MaxDate Then v = _MaxDate
_Date = v
ShowDate()
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_MinDate As Date
Get
Return _MinDate
End Get
Set(value As Date)
Dim v As Date = Midday(value)
_MinDate = v
If _MaxDate < v Then _MaxDate = v
If _Date < v Then _Date = v
ShowDate()
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_MaxDate As Date
Get
Return _MaxDate
End Get
Set(value As Date)
Dim v As Date = Midday(value)
_MaxDate = v
If _MinDate > v Then _MinDate = v
If _Date > v Then _Date = v
ShowDate()
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_FontSize As Integer
Get
Return CInt(Math.Round(_Font.Size))
End Get
Set(value As Integer)
Dim v As Integer = value
If v < 8 Then v = 8
If v > 50 Then v = 50
If Not Control_Is_Ready Then Exit Property
_Font = New Font(_Font.Name, v, _Font.Style)
For i As Integer = 0 To 3
lab(i).Font = _Font
Next
ResizeAll()
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_Font As Font
Get
Return _Font
End Get
Set(value As Font)
If Not Control_Is_Ready Then Exit Property
Dim v As Integer = CInt(value.Size)
If v < 8 Then v = 8
If v > 50 Then v = 50
_Font = New Font(value.Name, v, value.Style)
For i As Integer = 0 To 3
lab(i).Font = _Font
Next
ResizeAll()
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_BtnColor As Color
Get
Return _BtnColour
End Get
Set(value As Color)
' dot net does not fully support transparent colours
_BtnColour = Color.FromArgb(255, value.R, value.G, value.B)
For i As Integer = 0 To 3
butU(i).BackColor = _BtnColour
butD(i).BackColor = _BtnColour
Next
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_TextForeColor As Color
Get
Return _TextForeColour
End Get
Set(value As Color)
' dot net does not fully support transparent colours
_TextForeColour = Color.FromArgb(255, value.R, value.G, value.B)
For i As Integer = 0 To 3
lab(i).ForeColor = _TextForeColour
Next
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_TextBackColor As Color
Get
Return _TextBackColour
End Get
Set(value As Color)
' dot net does not fully support transparent colours
_TextBackColour = Color.FromArgb(255, value.R, value.G, value.B)
For i As Integer = 0 To 3
lab(i).BackColor = _TextBackColour
Next
End Set
End Property
<DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
Public Property A_CtlBackColor As Color
Get
Return _CtlBackColour
End Get
Set(value As Color)
' dot net does not fully support transparent colours
_CtlBackColour = Color.FromArgb(255, value.R, value.G, value.B)
Me.BackColor = _CtlBackColour
End Set
End Property
End Class
Properties
| Property | Type | Description |
| A_Date | Date | Get/Set Date displayed in the control |
| A_MinDate | Date | Get/Set Date the earliest date that control will accept |
| A_MaxDate | Date | Get/Set Date the latest date that control will accept |
| A_FontSize | Integer |
Get/Set Date the size of font used for date. Changing font size will change the size of control |
| A_Font | Font |
Get/Set Date the font used for date. Changing font could change the size of control |
| A_BtnColor | Color | Get/Set the colour of the buttons |
| A_TextForeColor | Color | Get/Set the colour of date-text |
| A_TextBackColor | Color | Get/Set the background colour of date-text |
| A_CtlBackColor | Color | Get/Set the background colour of control |
DigitalDan.co.uk