Option Explicit
' Version-independent date-picker form, entirely
' built in MSForms controls and native VBA.
' Note that the date-selector functions for month
' and year respect end-of-month: jumping back one
' month from March 31st goes to February 28th and
' jumping forward one month from Feb 28th goes to
' March 31st - not March 28th, the result you get
' using the native Excel and VBA date arithmetic.
' ********************************************
' Author: Nigel Heffernan
' June 2013 http://excellerando.blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
' You are advised to segregate this code from
' any proprietary or commercially-confidential
' source code, and to label it clearly. If you
' fail do do so, there is a risk that you will
' impair your right to assert ownership of any
' intellectual property embedded in your work;
' or impair your employers or clients' ability
' to do so if the intellectual property rights
' in your work have been assigned to them.
'
' You are free to use this code as-is, but all
' use is entirely at your own risk: the author
' accepts no liability arising from the use of
' this source code or any work derived from it
' and no warranty is offered or implied.
'
' * YOU ARE EXPECTED TO DO YOUR OWN TESTING *
'
' You are asked, as a matter of professional
' courtesy, to acknowledge the author of any
' source code that you incorporate into your
' work, with a link to author's website or a
' link to the relevant open-source community
' site if that was where you found the code.
'
' You are strongly advised to include both the
' copyright and liability disclaimers, and to
' consult your company's legal advisors with a
' view to providing equivalent and appropriate
' notices and disclaimers.
' ********************************************
'SAMPLE USAGE: FUNCTION TO OPEN THE FORM AND RETURN THE SELECTED DATE
'Option Explicit
'Option Private Module ' Don't expose this for use in formulas
'Public Function DatePicker(Optional StartDate As Date = 0, _
' Optional LinkedCell As Excel.Range, _
' Optional Caption As String = "Select date") As Date
'
'' Open a date picker form and return the date selected by the user.
'
'' This function respects end-of-month: jumping forward a month from
'' February 28th lands on March 31st, not March 28th.
'
'' Clicking Cancel, or the form's window close button, will discard
'' the user's selection and return the initial date.
'If StartDate = 0 Then
' StartDate = VBA.Date
'End If
'
'With frmDatePicker
'
' .Caption = Caption
'
' If LinkedCell Is Nothing Then
' ' no action
' ElseIf Not IsDate(LinkedCell.Cells(1, 1).Value) Then
' ' no action
' Else
' .txtSelectedDate.ControlSource = Chr(39) & LinkedCell.Worksheet.Name & Chr(39) & "!" & LinkedCell.Cells(1, 1).Address
' If IsDate(LinkedCell.Value) Or IsNumeric(LinkedCell.Value2) Then
' StartDate = CVDate(LinkedCell.Value)
' Else
' StartDate = VBA.Date
' End If
' End If
'
' .InitialDate = StartDate
'
' .StartUpPosition = 0 'manual
' .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
' .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
'
' .Show
'
'End With
'
'' This 'With' block exit and re-entry avoids OLE disconnection errors if the form window is closed
'
'With frmDatePicker
'
' If .Cancel Then
'
' DatePicker = StartDate
' If Not LinkedCell Is Nothing Then
' LinkedCell.Value2 = StartDate
' End If
'
' Else
'
' DatePicker = .SelectedDate
' If Not LinkedCell Is Nothing Then
' LinkedCell.Value2 = .SelectedDate
' End If
'
' End If
'
'End With
'
'
'Unload frmDatePicker
'
'End Function
' *************************************************************************************
#If VBA7 And Win64 Then ' 64 bit Excel
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#Else ' 32 bit Excel
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Const BTN_MEDIUM As Long = &HE0E0E0
Private Const BTN_DARK_1 As Long = &HD0D0D0
Private Const BTN_LIGHT As Long = &HF0F0F0
Private Const FONT_DARK As Long = &H800000
Private Const FONT_LIGHT As Long = &HFFFFA0
Private Const FONT_GREY As Long = &H808080
Private Const BTN_DELAY As Long = 150
Private Const YEAR_START As Long = -3
Private m_dtSelected As Date ' The selected date, as displayed
Private m_dtInitial As Date ' an initial date set externally by a VBA caller
Private m_BaseDate As Date ' A nominal date corresponding to day button zero
Private m_Month As Long ' The current month (as 1-12)
Private m_Year As Long ' The current year
Public Cancel As Boolean ' Cancel remains true until the user performs some
' action that selects a date, or clicks 'OK'
Public Property Get InitialDate() As Date
InitialDate = m_dtInitial
End Property
Public Property Let InitialDate(DateInitial As Date)
' InitialDate is the date returned to callers when Cancel=True
' Cancel is set TRUE on initialisation, or on setting this property
' All user actions that select a date set Cancel=False
' The user action 'Cancel' sets Cancel=True
m_dtInitial = DateInitial
SelectedDate = m_dtInitial
Cancel = True
End Property
Public Property Get SelectedDate() As Date
' Return the date currently selected
SelectedDate = m_dtSelected
End Property
Public Property Let SelectedDate(DateSelected As Date)
Dim lngLabel As Long
Dim strLabel As String
On Error Resume Next
Application.EnableEvents = False
m_dtSelected = DateSelected
If m_Month <> Month(DateSelected) Or m_Year <> Year(DateSelected) Then
m_Month = Month(DateSelected)
m_Year = Year(DateSelected)
'ResetFormats
DisplayMonth m_Year, m_Month
End If
'lng Label is the ordinal (1 to 42) of the 'day' button for the selected date
lngLabel = DateSelected - m_BaseDate
strLabel = "day" & Right("00" & lngLabel, 2)
DayButton_Click Me.Controls(strLabel)
Me.txtSelectedDate = Format(DateSelected, "dd-mmm-yyyy")
Me.cboMonth.Text = Format(DateSelected, "mmmm")
Me.cboYear.Text = Format(DateSelected, "yyyy")
Me.Cancel = False
Application.EnableEvents = True
End Property
Private Sub DisplayMonth(iYear As Long, lngMonth As Long)
Dim lngStartDate As Long ' First day of this month
Dim lngEndDate As Long ' First day of this month
Dim strCtrlName As String
Dim lngLabel As Long
Dim lngWeekDay As Long
Dim lngDate As Long ' local variable, incremented in a loop
lngStartDate = DateSerial(iYear, lngMonth, 1)
lngEndDate = DateSerial(iYear, lngMonth + 1, 1) - 1 ' DateSerial(2014, 13, 1) ' actually works in VBA
lngWeekDay = Weekday(lngStartDate)
m_BaseDate = lngStartDate - lngWeekDay
For lngLabel = 1 To 42
lngDate = m_BaseDate + lngLabel
strCtrlName = "day" & Right("00" & lngLabel, 2)
With Me.Controls(strCtrlName)
.Caption = Day(lngDate)
If lngDate = m_dtSelected Then
FormatSelected Me.Controls(strCtrlName)
Else
FormatDeselected Me.Controls(strCtrlName), lngMonth
End If
End With
Next lngLabel
End Sub
Private Sub FormatSelected(ctrl As MSForms.Control)
' format the day selector control for a selection 'click'
Dim lngLabel As Integer
With ctrl
.SpecialEffect = fmSpecialEffectSunken
lngLabel = CInt(Right(.Name, 2))
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT - &H606060
Else
.BackColor = BTN_MEDIUM - &H606060
End If
.ForeColor = &HFFFFB0 ' FONT_LIGHT
.Font.Bold = True
End With
End Sub
Private Sub FormatDeselected(ctrl As MSForms.Control, Optional lngMonth As Long = 0)
' format the day selector control for a selection 'click'
Dim lngLabel As Integer
Dim lngDate As Long
If lngMonth = 0 Then
lngMonth = Month(m_dtSelected)
End If
With ctrl
.SpecialEffect = fmSpecialEffectEtched
lngLabel = CInt(Right(.Name, 2))
lngDate = m_BaseDate + lngLabel
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT
Else
.BackColor = BTN_MEDIUM
End If
.Font.Bold = False
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT
Else
.BackColor = BTN_MEDIUM
End If
If Month(lngDate) = lngMonth Then
'.Enabled = True
.ForeColor = FONT_DARK
Else
'.Enabled = False
.ForeColor = FONT_GREY
.BackColor = BTN_MEDIUM
End If
End With
End Sub
Private Sub DayButton_Click(ctrlClicked As MSForms.Control, Optional SetDate As Boolean = True)
Dim lngLabel As Integer
Dim ctrl As MSForms.Control
For Each ctrl In Me.Controls
' Enforce 'toggle' behaviour: deselect any other date button that's selected
If Left(ctrl.Name, 3) = "day" And ctrl.Name <> ctrlClicked.Name Then
If ctrl.SpecialEffect = fmSpecialEffectSunken Then
FormatDeselected ctrl
End If
End If
Next
With ctrlClicked
lngLabel = CInt(Right(.Name, 2))
If .SpecialEffect = fmSpecialEffectEtched Then
FormatSelected ctrlClicked
If SetDate Then
SelectedDate = m_BaseDate + lngLabel
End If
End If
End With
End Sub
Private Sub cboMonth_Change()
Dim lngDate As Date
Dim lngMonth As Long
Dim lngShift As Long
If Application.EnableEvents = False Then Exit Sub
lngDate = SelectedDate
lngMonth = cboMonth.ListIndex + 1
lngShift = lngMonth - Month(lngDate)
ShiftMonth lngShift
End Sub
Public Sub ShiftMonth(lngShift As Long)
Dim lngDate As Date
lngDate = SelectedDate
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If DateSerial(Year(lngDate), Month(lngDate) + 1, 1) - 1 = lngDate Then ' start from EOM
SelectedDate = DateSerial(Year(lngDate), Month(lngDate) + lngShift + 1, 1) - 1
ElseIf DateSerial(Year(lngDate), Month(lngDate), 1) = lngDate Then ' start from BOM
SelectedDate = DateSerial(Year(lngDate), Month(lngDate) + lngShift, 1)
Else
SelectedDate = DateAdd("m", lngShift, lngDate)
End If
End Sub
Private Sub cboYear_Change()
If Application.EnableEvents = False Then Exit Sub
Dim lngDate As Date
Dim lngYear As Long
Dim lngShift As Long
If Len(cboYear.Text) < 2 Then Exit Sub
lngDate = SelectedDate
lngYear = cboYear.Text
If lngYear > -1 And lngYear < 100 Then
lngYear = Year(SelectedDate) - (Year(SelectedDate) Mod 100) + lngYear
End If
lngShift = lngYear - Year(lngDate)
ShiftYear lngShift
End Sub
Public Sub ShiftYear(lngShift As Long)
Dim lngDate As Date
lngDate = SelectedDate
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If DateSerial(Year(lngDate), Month(lngDate) + 1, 1) - 1 = lngDate Then ' start from EOM
SelectedDate = DateSerial(Year(lngDate) + lngShift, Month(lngDate) + 1, 1) - 1
ElseIf DateSerial(Year(lngDate), Month(lngDate), 1) = lngDate Then ' start from BOM
SelectedDate = DateSerial(Year(lngDate) + lngShift, Month(lngDate), 1)
Else
SelectedDate = DateAdd("yyyy", lngShift, lngDate)
End If
End Sub
' *** Note the use of label controls instead of MSForms butttons
' The MS Forms 'button' controls don't support the fine detail we
' need in this kind of densely-packed and densely-functional form
Private Sub cmdDateDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdDateDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = Me.SelectedDate - 1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdDateInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdDateInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = Me.SelectedDate + 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdMonthDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdMonthDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftMonth -1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdMonthInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdMonthInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftMonth 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdYearDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdYearDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftYear -1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdYearInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdYearInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftYear 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdCancel_Click()
cmdCancel.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = m_dtInitial
Me.Cancel = True
cmdCancel.SpecialEffect = fmSpecialEffectEtched
Me.Hide
End Sub
Private Sub cmdOK_Click()
cmdOK.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
cmdOK.SpecialEffect = fmSpecialEffectEtched
Me.Hide
End Sub
Private Sub txtSelectedDate_Change()
Dim lngYear As Long
Dim strDate As String
Dim arrDate As Variant
Dim lngDate As Variant
Dim varTemp As Variant
If Application.EnableEvents = False Then Exit Sub
txtSelectedDate.Text = Replace(txtSelectedDate.Text, "/", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, " ", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, ",", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, ".", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, "--", "-")
arrDate = Split(txtSelectedDate.Text, "-")
If UBound(arrDate) < 2 Then Exit Sub
If UBound(arrDate) > 2 Then ReDim Preserve arrDate(0 To 2)
If Len(CStr(arrDate(0))) > 2 Then
' Swap mmm-dd-yyyy to dd-mmm-yyyy
If IsNumeric(arrDate(1)) And Not IsNumeric(arrDate(0)) Then
varTemp = arrDate(0)
arrDate(0) = arrDate(1)
arrDate(1) = varTemp
' Swap 05-26-2011 to 26-05-2011
If IsNumeric(arrDate(1)) And IsNumeric(arrDate(0)) Then
If arrDate(1) > 12 And arrDate(0) < 12 Then
varTemp = arrDate(0)
arrDate(0) = arrDate(1)
arrDate(1) = varTemp
End If
End If
' Swap yyyy-mmm-dd to dd-mmm-yyyy
ElseIf Len(CStr(arrDate(0))) = 4 And Len(arrDate(2)) < 3 Then
varTemp = arrDate(0)
arrDate(0) = arrDate(2)
arrDate(2) = varTemp
End If
End If
If Not IsNumeric(arrDate(0)) Then Exit Sub
If arrDate(0) < 1 Then Exit Sub
If Not IsNumeric(arrDate(2)) Then
Exit Sub
ElseIf Len(arrDate(2)) < 2 Then
Exit Sub 'do nothing, the user is still typing the year
ElseIf Left(arrDate(2), 2) = CStr((Year(Date) \ 100)) And Len(arrDate(2)) < 4 Then
Exit Sub 'do nothing, the user is still typing the year
End If
strDate = "00" & Right(arrDate(0), 2) & "-" & arrDate(1) & "-" & arrDate(2)
If IsDate(strDate) Then
Me.SelectedDate = CVDate(strDate)
End If
End Sub
Private Sub txtSelectedDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With txtSelectedDate
If IsDate(.Value) Then
Select Case .SelStart
Case 1, 2
Me.SelectedDate = Me.SelectedDate + 1
Case 3, 4, 5, 6
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If Month(SelectedDate + 1) <> Month(SelectedDate) Then
SelectedDate = DateSerial(Year(SelectedDate), Month(SelectedDate) + 2, 1) - 1
Else
SelectedDate = DateAdd("m", 1, SelectedDate)
End If
Case Is > 7
' However, we do not apply EOM logic for leap years: it surprises the users
SelectedDate = DateAdd("yyyy", 1, SelectedDate)
End Select
End If
End With
End Sub
Private Sub txtSelectedDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'Supports direct user edits in the control
If IsDate(txtSelectedDate.Value) Then
If Me.SelectedDate <> CVDate(txtSelectedDate.Value) Then
Me.SelectedDate = CVDate(txtSelectedDate.Value)
End If
End If
End Sub
Private Sub UserForm_Initialize()
Dim lngLabel As Long
Dim strLabel As String
Dim lngDate As Long
Me.Caption = "Select Date"
SelectedDate = Date
' Populate day name labels, lblDay1 to lblDay7
' Doing this in code picks up the locale's day
' abbreviations - test this on a 'French' PC
lngDate = SelectedDate
Do Until Weekday(lngDate) = 7
lngDate = lngDate + 1
Loop
For lngLabel = 1 To 7
strLabel = "lblDay" & lngLabel
Me.Controls(strLabel).Caption = Format(lngDate + lngLabel, "ddd")
Next lngLabel
lngDate = SelectedDate
With cboMonth
.Clear
For lngLabel = 1 To 12
.AddItem Format(DateSerial(Year(lngDate), lngLabel, 1), "mmmm")
Next lngLabel
.ListIndex = Month(lngDate) - 1
End With
lngDate = SelectedDate
With cboYear
.Clear
For lngLabel = YEAR_START To 10
.AddItem Year(lngDate) + lngLabel
Next lngLabel
.ListIndex = -YEAR_START
End With
Me.InitialDate = lngDate ' This also sets Me.Cancel = True
' Cancel remains true until the user selects a date
End Sub
Private Sub day01_Click(): DayButton_Click day01: End Sub
Private Sub day02_Click(): DayButton_Click day02: End Sub
Private Sub day03_Click(): DayButton_Click day03: End Sub
Private Sub day04_Click(): DayButton_Click day04: End Sub
Private Sub day05_Click(): DayButton_Click day05: End Sub
Private Sub day06_Click(): DayButton_Click day06: End Sub
Private Sub day07_Click(): DayButton_Click day07: End Sub
Private Sub day08_Click(): DayButton_Click day08: End Sub
Private Sub day09_Click(): DayButton_Click day09: End Sub
Private Sub day10_Click(): DayButton_Click day10: End Sub
Private Sub day11_Click(): DayButton_Click day11: End Sub
Private Sub day12_Click(): DayButton_Click day12: End Sub
Private Sub day13_Click(): DayButton_Click day13: End Sub
Private Sub day14_Click(): DayButton_Click day14: End Sub
Private Sub day15_Click(): DayButton_Click day15: End Sub
Private Sub day16_Click(): DayButton_Click day16: End Sub
Private Sub day17_Click(): DayButton_Click day17: End Sub
Private Sub day18_Click(): DayButton_Click day18: End Sub
Private Sub day19_Click(): DayButton_Click day19: End Sub
Private Sub day20_Click(): DayButton_Click day20: End Sub
Private Sub day21_Click(): DayButton_Click day21: End Sub
Private Sub day22_Click(): DayButton_Click day22: End Sub
Private Sub day23_Click(): DayButton_Click day23: End Sub
Private Sub day24_Click(): DayButton_Click day24: End Sub
Private Sub day25_Click(): DayButton_Click day25: End Sub
Private Sub day26_Click(): DayButton_Click day26: End Sub
Private Sub day27_Click(): DayButton_Click day27: End Sub
Private Sub day28_Click(): DayButton_Click day28: End Sub
Private Sub day29_Click(): DayButton_Click day29: End Sub
Private Sub day30_Click(): DayButton_Click day30: End Sub
Private Sub day31_Click(): DayButton_Click day31: End Sub
Private Sub day32_Click(): DayButton_Click day32: End Sub
Private Sub day33_Click(): DayButton_Click day33: End Sub
Private Sub day34_Click(): DayButton_Click day34: End Sub
Private Sub day35_Click(): DayButton_Click day35: End Sub
Private Sub day36_Click(): DayButton_Click day36: End Sub
Private Sub day37_Click(): DayButton_Click day37: End Sub
Private Sub day38_Click(): DayButton_Click day38: End Sub
Private Sub day39_Click(): DayButton_Click day39: End Sub
Private Sub day40_Click(): DayButton_Click day40: End Sub
Private Sub day41_Click(): DayButton_Click day41: End Sub
Private Sub day42_Click(): DayButton_Click day42: End Sub
Sunday, 23 June 2013
Code for a version-independent date picker
By now, you're either working entirely in 64-bit windows and the 64-bit versions of VBA in Office 2010 and 2013, or sort-of-stuck with running office in 32-bit mode because all the 32-bit OCX and COM objects are broken.
A good (or bad) example of this is the Date-Picker control, and I ended up coding a native VBA version that runs on either OS.
This code won't do it all for you: you've got to build the form and create the controls - I don't do downloads on this server - but it's a good overview of the coding you've got to do to make a date-picker work.
Subscribe to:
Post Comments (Atom)
No comments:
Post a Comment