Dim dayNames As Variant, monthNames As Variant, daysMonth As Variant
Dim canUpdate As Integer, selectDate As Date
Sub FillVars(Optional sD As Date = 0)
Dim i As Integer, thisBox, thisLabel
Dim posX As Integer, posY As Integer, widthDay As Integer, heightDay As Integer
dayNames = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
monthNames = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
daysMonth = Array(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
If sD = 0 Then
selectDate = Date
Else
selectDate = sD
End If
canUpdate = 1
widthDay = 30
heightDay = 20
posX = widthDay / 2
With DatePick.Controls("Label8")
.Top = heightDay / 2
.Left = widthDay / 2
.Font.Size = 16
.Font.Bold = True
.Caption = monthNames(DatePart("m", Date) - 1) & " " & DatePart("yyyy", Date)
.Height = heightDay * 1.5
.Width = 150
End With
For i = 1 To 7
Set thisLabel = DatePick.Controls("Label" & i)
With thisLabel
.Caption = dayNames(i - 1)
.Font.Size = 10
.Font.Bold = True
.Top = heightDay * 2
.Left = posX
.Width = widthDay
.Height = heightDay
End With
posX = posX + widthDay
Next i
posX = widthDay / 2
posY = heightDay * 3
For i = 1 To 37
Set thisBox = DatePick.Controls("TextBox" & i)
With thisBox
.Top = posY
.Left = posX
.Width = widthDay
.Height = heightDay
End With
If i / 7 = Int(i / 7) Then
posX = widthDay / 2
posY = posY + heightDay
Else
posX = posX + widthDay
End If
Next i
posY = posY + heightDay
With ComboBox1
.Left = widthDay / 2
.Top = posY + heightDay / 2
.Width = widthDay * 3.5
.Height = heightDay
For i = 1 To 12
.AddItem monthNames(i - 1)
Next i
.ListIndex = DatePart("m", Date) - 1
.Style = fmStyleDropDownList
End With
With ComboBox2
.Left = widthDay * 5
.Top = posY + heightDay / 2
.Height = heightDay
.Width = widthDay * 2
For i = -9 To 10
.AddItem DatePart("yyyy", Date) + i
Next i
.ListIndex = 9
.Style = fmStyleDropDownList
End With
With SpinButton1
.Left = widthDay * 4
.Top = posY + heightDay / 2
.Height = heightDay
.Width = widthDay / 2
.Min = 0
.Max = 11
.Value = ComboBox1.ListIndex
End With
With SpinButton2
.Left = widthDay * 7
.Top = posY + heightDay / 2
.Height = heightDay
.Width = widthDay / 2
.Min = 0
.Max = 19
.Value = ComboBox2.ListIndex
End With
With CommandButton1
.Caption = "Cancel"
.Top = posY + heightDay * 2
.Height = heightDay
.Left = widthDay * 5.5
.Width = widthDay * 2
.Font.Size = 12
End With
With DatePick
.Width = 8 * widthDay
.Height = CommandButton1.Top + 2.5 * heightDay
.Caption = "Choose Date"
End With
Call SetDays(Date)
canUpdate = canUpdate - 1
End Sub
Private Sub ComboBox1_Change()
If canUpdate = 0 Then
canUpdate = canUpdate + 1
Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text
Call SetDays(DateValue(ComboBox1.Text & " 1, " & ComboBox2.Text))
SpinButton1.Value = ComboBox1.ListIndex
canUpdate = canUpdate - 1
End If
End Sub
Private Sub ComboBox2_Change()
If canUpdate = 0 Then
canUpdate = canUpdate + 1
Label8.Caption = ComboBox1.Text & " " & ComboBox2.Text
Call SetDays(DateValue(ComboBox1.Text & " 1, " & ComboBox2.Text))
SpinButton2.Value = ComboBox2.ListIndex
canUpdate = canUpdate - 1
End If
End Sub
Private Sub CommandButton1_Click()
Unload DatePick
End Sub
Private Sub SpinButton1_Change()
ComboBox1.ListIndex = SpinButton1.Value
End Sub
Private Sub SpinButton2_Change()
ComboBox2.ListIndex = SpinButton2.Value
End Sub
Private Sub TextBox1_enter()
Call SetNewDate(TextBox1.Text)
End Sub
Private Sub TextBox2_enter()
Call SetNewDate(TextBox2.Text)
End Sub
Private Sub TextBox3_enter()
Call SetNewDate(TextBox3.Text)
End Sub
Private Sub TextBox4_enter()
Call SetNewDate(TextBox4.Text)
End Sub
Private Sub TextBox5_enter()
Call SetNewDate(TextBox5.Text)
End Sub
Private Sub TextBox6_enter()
Call SetNewDate(TextBox6.Text)
End Sub
Private Sub TextBox7_enter()
Call SetNewDate(TextBox7.Text)
End Sub
Private Sub TextBox8_enter()
Call SetNewDate(TextBox8.Text)
End Sub
Private Sub TextBox9_enter()
Call SetNewDate(TextBox9.Text)
End Sub
Private Sub TextBox10_enter()
Call SetNewDate(TextBox10.Text)
End Sub
Private Sub TextBox11_enter()
Call SetNewDate(TextBox11.Text)
End Sub
Private Sub TextBox12_enter()
Call SetNewDate(TextBox12.Text)
End Sub
Private Sub TextBox13_enter()
Call SetNewDate(TextBox13.Text)
End Sub
Private Sub TextBox14_enter()
Call SetNewDate(TextBox14.Text)
End Sub
Private Sub TextBox15_enter()
Call SetNewDate(TextBox15.Text)
End Sub
Private Sub TextBox16_enter()
Call SetNewDate(TextBox16.Text)
End Sub
Private Sub TextBox17_enter()
Call SetNewDate(TextBox17.Text)
End Sub
Private Sub TextBox18_enter()
Call SetNewDate(TextBox18.Text)
End Sub
Private Sub TextBox19_enter()
Call SetNewDate(TextBox19.Text)
End Sub
Private Sub TextBox20_enter()
Call SetNewDate(TextBox20.Text)
End Sub
Private Sub TextBox21_enter()
Call SetNewDate(TextBox21.Text)
End Sub
Private Sub TextBox22_enter()
Call SetNewDate(TextBox22.Text)
End Sub
Private Sub TextBox23_enter()
Call SetNewDate(TextBox23.Text)
End Sub
Private Sub TextBox24_enter()
Call SetNewDate(TextBox24.Text)
End Sub
Private Sub TextBox25_enter()
Call SetNewDate(TextBox25.Text)
End Sub
Private Sub TextBox26_enter()
Call SetNewDate(TextBox26.Text)
End Sub
Private Sub TextBox27_enter()
Call SetNewDate(TextBox27.Text)
End Sub
Private Sub TextBox28_enter()
Call SetNewDate(TextBox28.Text)
End Sub
Private Sub TextBox29_enter()
Call SetNewDate(TextBox29.Text)
End Sub
Private Sub TextBox30_enter()
Call SetNewDate(TextBox30.Text)
End Sub
Private Sub TextBox31_enter()
Call SetNewDate(TextBox31.Text)
End Sub
Private Sub TextBox32_enter()
Call SetNewDate(TextBox32.Text)
End Sub
Private Sub TextBox33_enter()
Call SetNewDate(TextBox33.Text)
End Sub
Private Sub TextBox34_enter()
Call SetNewDate(TextBox34.Text)
End Sub
Private Sub TextBox35_enter()
Call SetNewDate(TextBox35.Text)
End Sub
Private Sub TextBox36_enter()
Call SetNewDate(TextBox36.Text)
End Sub
Private Sub TextBox37_enter()
Call SetNewDate(TextBox37.Text)
End Sub
Private Sub SetNewDate(setDay As Integer)
If canUpdate = 0 Then
Call returnDate(DateValue(ComboBox1.Text & " " & setDay & ", " & ComboBox2.Text))
Unload DatePick
End If
End Sub
Private Sub UserForm_Initialize()
End Sub
Sub SetDays(tempDate As Date)
Dim i As Integer, Day, numDay As Integer
tempDate = DateValue(monthNames(DatePart("m", tempDate) - 1) & " 1, " & DatePart("yyyy", tempDate))
numDay = DatePart("w", tempDate)
If DatePart("yyyy", tempDate) / 4 = DatePart("yyyy", tempDate) \ 4 Then
daysMonth(1) = 29
Else
daysMonth(1) = 28
End If
If numDay > 1 Then
For i = 1 To numDay - 1
DatePick.Controls("TextBox" & i).Enabled = False
DatePick.Controls("TextBox" & i).Visible = False
Next i
End If
For i = 1 To daysMonth(DatePart("m", tempDate) - 1)
With DatePick.Controls("TextBox" & (numDay + i - 1))
.Visible = True
.Enabled = True
.Text = i
.Locked = True
.TabStop = False
.BackStyle = fmBackStyleTransparent
.ForeColor = RGB(0, 0, 0)
.Font.Bold = False
If DatePart("yyyy", Date) = ComboBox2.Text And monthNames(DatePart("m", Date) - 1) = ComboBox1.Text Then
If DatePart("d", Date) = i Then
.ForeColor = RGB(255, 0, 0)
.Font.Bold = True
End If
End If
If DatePart("yyyy", selectDate) = ComboBox2.Text And monthNames(DatePart("m", selectDate) - 1) = ComboBox1.Text Then
If DatePart("d", selectDate) = i Then .BackStyle = fmBackStyleOpaque
End If
End With
Next i
For i = daysMonth(DatePart("m", tempDate) - 1) + numDay To 37
With DatePick.Controls("TextBox" & i)
.Enabled = False
.Visible = False
End With
Next i
End Sub
6. Insert a Module into the project.
Dim displayDate As Date
Sub test()
displayDate = DateValue("July 16, 2005")
Load DatePick
' If this code is in a form, the following shows how to place the calendar position at the calling control
' DatePick.startupposition = 3
' DatePick.Left = UserForm1.Left + CommandButton1.Left
' DatePick.Top = UserForm1.Top + CommandButton1.Top
' Note: If date not supplied to DatePick, current date will be used.
Call DatePick.FillVars(displayDate)
DatePick.Show
MsgBox "American notation: " & DatePart("m", displayDate) & "/" & DatePart("d", displayDate) & "/" & DatePart("yyyy", displayDate)
End Sub
Sub returnDate(dD As Date)
displayDate = dD
End Sub
8. To test, run the macro named test()