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.


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




No comments:

Post a Comment