Nifty Date Picker

There are some excellent date pickers available on the internet. So why should you use mine?

First of all I’ve included details of my thought processes when I constructed it, including where I went wrong! This in itself will prove useful for anyone who wants to build stuff in MS Access.

It also gives you a very good handle on it, particularly if you want to modify this nifty date picker for your own particular use. I have also included a presentation, and a YouTube explaining how it works.

If that’s not enough, then watch this space! This is just a beginning, I intend incorporating this “Nifty Date Picker” (Calendar Control) with my “Nifty Call Called” Class Module. The combination of the two will add some sophisticated functionality with benefit of ease of use.

With the class module added, you just need to call the Pop-Up calendar form “Nifty Date Picker” from any control and it will just work. It will take the caption from the Controls label and use that as the caption for the popup calendar form without you doing a thing! No coding!

Simulated After Update Event

By adding a simple piece of VBA code to your calling form, then the calendar form will be able to simulate the afterupdate event of the control it is associated with. This means if you have two dates, a person’s date of birth, and today’s date, then the code will automatically calculate the person’s age without you having to press any other button. I haven’t seen this functionality anywhere else.

Other benefits, the class module is a class! In essence it’s a very simple class, plus I’ve done a playlist on YouTube here which runs through the functionality of the class module and also how to associate it with your own pop-up form.

Object Oriented – Nifty Access

DATE PICKER for ALL VERSIONS of ACCESS

Heading HERE...

Video 1 (18:39)

I demonstrate in this YouTube video “Access Date Picker for ALL Versions of MS Access” — https://youtu.be/q1syYwHJVwI — I show you how to put together your own Date Picker Form to create yourself a Nifty Date Picker! Why? Well a lot of code examples are only available in the later versions of MS Access (accdb). This means the example won’t work in earlier versions of MS Access!

I realised this applied to my recent Access Date Picker Form, it won’t work in older versions of MS Access. However; I suspect the VBA code will.

You can download the VBA code BELOW and then construct the MS Access Form following the YouTube video instructions… “Hey Presto” You should end up with a nice Access Date Picker that will work in your version (ANY VERSION) of MS Access.

Alternatively save yourself a lot of time and trouble and download the ready-made Access Date Picker – click on the link below:-

Buy now

If you are like me, then you probably object to spending money on something you think you should have done yourself. Or maybe you feel guilty for paying for something you could have got for free. But look at it like this, I’ve done the work for you, it’s there waiting for you to use – no hassle – no trouble, and for what? The price of a cup of coffee! I’d love a coffee! press the button go on! By Me one!

Video 1 (18:39)

Buy Tony a coffee!

… …

Option Compare Database
Option Explicit

'This is the latest version of the code, Updated March the 11th 2019
'Fixed a bug with highlighting the date, removed a bit of redundant code.

'I have removed all my custom error handling code from this free sample.

'######## -------------- Variables for the Property Statements ------- ########
Private mctrlInitialDate As Control
Private mTempDate As Date 'Temporary Date

'############## ---------------- Property Statements ----------------- ########
Property Set prpCtrlInitialDate(ctrlInitialDate As Control)
    Set mctrlInitialDate = ctrlInitialDate
End Property      'prpCtrlInitialDate Let

Property Get prpCtrlInitialDate() As Control
   Set prpCtrlInitialDate = mctrlInitialDate
End Property      'prpCtrlInitialDate Get

Property Let prpTempDate(ByVal datTempDate As Date)
    mTempDate = datTempDate
End Property      'prpTempDate Let

Property Get prpTempDate() As Date
    prpTempDate = mTempDate
End Property      'prpTempDate Get

'############## ------------------ Control Events -------------------- ########
Private Sub btnToday_Click()
    prpTempDate = Date
    Me.txtMth = prpTempDate
    Call fDisplayMth(prpTempDate)
    Call fSetAndClose(True)
End Sub      'btnToday_Click

Private Sub btnYrPlus1_Click()
    prpTempDate = DateAdd("yyyy", 1, prpTempDate)
    Me.txtMth = prpTempDate
    Call fDisplayMth(prpTempDate)
End Sub      'btnYrPlus1_Click

Private Sub btnYrMinus1_Click()
    prpTempDate = DateAdd("yyyy", -1, prpTempDate)
    Me.txtMth = prpTempDate
    Call fDisplayMth(prpTempDate)
End Sub      'btnYrMinus1_Click

Private Sub btnMthMinus1_Click()
    prpTempDate = DateAdd("m", -1, prpTempDate)
    Me.txtMth = prpTempDate
    Call fDisplayMth(prpTempDate)
End Sub      'btnMthMinus1_Click

Private Sub btnMthPlus1_Click()
    prpTempDate = DateAdd("m", 1, prpTempDate)
    Me.txtMth = prpTempDate
    Call fDisplayMth(prpTempDate)
End Sub      'btnMthPlus1_Click

Private Sub Form_Load()
    Me.Caption = Me.Name & " Ver B_1a "
End Sub      'Form_Load

Private Sub txtMth_AfterUpdate()
     prpTempDate = Me.txtMth
    Call fDisplayMth(prpTempDate)
End Sub      'txtMth_AfterUpdate

'############## ----------------- Primary Routines ------------------ ########
Public Function fSetUp()

        If Not IsDate(prpCtrlInitialDate) Then  'Handle No Date Supplied
            prpTempDate = Date
        Else
            prpTempDate = prpCtrlInitialDate    'Separate the Object Date from the Processed Date
        End If

        Me.txtMth = prpTempDate

        Call fDisplayMth(prpTempDate)

End Function      'fSetUp

Private Function fHighlightCurDate(ByVal dTempDate As Date, ByVal dInitialDate As Date)

Dim intInitialDay As Integer
intInitialDay = DatePart("d", dInitialDate)

    'If the Day matches the month and year, then highlight it
    If (DatePart("m", dTempDate) = DatePart("m", dInitialDate)) And (DatePart("yyyy", dTempDate) = DatePart("yyyy", dInitialDate)) Then
        Dim Ctrl As Control
           For Each Ctrl In Me.Controls
               Select Case Ctrl.ControlType
                   Case acCommandButton
                       If Ctrl.Caption = intInitialDay And Ctrl.Tag = "C" Then
                           Ctrl.FontSize = 11
                           Ctrl.ForeColor = RGB(255, 255, 255)
                           Ctrl.BackColor = RGB(30, 144, 255)
                       End If
               End Select
           Next Ctrl
    End If
End Function      'fHighlightCurDate

Private Function fDisplayMth(dInitialDate As Date)

Dim Ctrl As Control
Dim dFirstDayOfMth As Date

Dim intInitialDay As Integer
Dim intLastDayPrevMth As Integer

Dim intBtnTag As Integer            'Increment from 1 through to 42
Dim intPrevMth As Integer           'Increment the Previous Months Dates
Dim intInitialMth As Integer        'Increment the Alpha Months Dates (Current, Passed in Mth)
Dim intFollowMth As Integer         'Increment the Following Months Dates

dFirstDayOfMth = DateSerial(Year(dInitialDate), Month(dInitialDate), 1)

intLastDayPrevMth = DatePart("d", dFirstDayOfMth - 1)
intInitialDay = DatePart("d", dInitialDate)

intInitialMth = 1
intFollowMth = 1

intPrevMth = intLastDayPrevMth - Weekday(dFirstDayOfMth, vbMonday) + 2   'fWeekDayOffSet(dFirstDayOfMth) + 2

    For Each Ctrl In Me.Controls
        Select Case Ctrl.ControlType
            Case acCommandButton
            
                'Check to see if it is a Command Button in the 1 to 42 Grid (Its Prefix will be btnD)
                    If Left(Ctrl.Name, 4) = "btnD" Then
                    
                    'Setup Form
                        Ctrl.BackColor = RGB(147, 202, 221)
                        Ctrl.ForeColor = RGB(16, 37, 63)
     
                            '1 through 42 Counter
                                intBtnTag = intBtnTag + 1
     
                                    'Fill the Previous Month
                                        If Weekday(dFirstDayOfMth, vbMonday) > 0 And intPrevMth <= intLastDayPrevMth Then
                                            Ctrl.Tag = "P"
                                            Ctrl.BackColor = RGB(219, 238, 244)
                                            Ctrl.Caption = intPrevMth               'Set the Captions of the Command Buttons to the Previous month
                                            intPrevMth = intPrevMth + 1
                                        End If

                                    'Fill the Initial Month
                                        If intBtnTag >= Weekday(dFirstDayOfMth, vbMonday) Then
                                            Ctrl.Caption = intInitialMth              'Set the Captions of the Command Buttons to the Alpha month
                                            'intInitialMth
                                            Ctrl.Tag = "C"
                                                
                                                intInitialMth = intInitialMth + 1 'this is a poor name! it's a DAY not a month (Incremented = Incr)
                                        End If
                            
                        'Fill the Following Month
                            If intInitialMth > fLastDayOfMth(dFirstDayOfMth) + 1 Then
                                Ctrl.Tag = "F"
                                Ctrl.BackColor = RGB(219, 238, 244)
                                Ctrl.Caption = intFollowMth                     'Set the Captions of the Command Buttons to the Following month
                                intFollowMth = intFollowMth + 1
                            End If
                    End If
      End Select
    Next Ctrl
    
    Call fHighlightCurDate(prpTempDate, prpCtrlInitialDate)

End Function      'fDisplayMth

Private Function fGetCaption() As String

'The Calendar displays the  3 dates sections, previous month, current month and Following month.
'A value is placed in the Tag property of the command button to identify which date section the button belongs to

Dim intday As Integer
intday = Screen.ActiveControl.Caption
    
    Select Case Screen.ActiveControl.Tag
        Case Is = "P"   'Previous Month
            prpTempDate = fDateBuilder(prpTempDate, -1, intday)
        Case Is = "C"   'Current Month
            prpTempDate = fDateBuilder(prpTempDate, 0, intday)
        Case Is = "F"   'Following Month
            prpTempDate = fDateBuilder(prpTempDate, 1, intday)
    End Select

Call fSetAndClose(True)

End Function      'fGetCaption

Private Function fDateBuilder(dTempDate As Date, intOffSet As Integer, intday As Integer) As Date
'Used in Function fGetCaption()

    Dim intYear As Integer
    Dim intMth As Integer
    
            dTempDate = DateAdd("m", intOffSet, dTempDate)
            intYear = DatePart("yyyy", dTempDate)
            intMth = DatePart("m", dTempDate)
    
    fDateBuilder = intYear & "/" & intMth & "/" & intday
            
End Function      'fDateBuilder

Private Function fSetAndClose(blnSetDate As Boolean)
'This is the Exit Routine
    If blnSetDate Then
        prpCtrlInitialDate = prpTempDate 'Set the Object Date to the Processed Date
        DoCmd.Close acForm, Me.Name
    End If
End Function     'fSetAndClose

'############## ----------------- Helper Routines ------------------ ########
Private Function fLastDayOfMth(dDate As Date) As Byte

'                                 DateSerial( year, month, day )
    fLastDayOfMth = DatePart("d", DateSerial(Year(dDate), Month(dDate) + 1, 1) - 1)

End Function      'fLastDayOfMth

''''CALL IT Like THIS
'''Dim strFrmName As String
'''    strFrmName = "NiftyDatePicker"
'''        DoCmd.OpenForm strFrmName
'''            With Forms(strFrmName)
'''                Set .prpCtrlInitialDate = Me.txtEndDate
'''                .fSetUp
'''                '.Caption = "I CAN CHANGE THE CAPTION"
'''            End With