Nifty Date Picker
More Links in the DATE MENU Below!
There are some excellent date pickers available on the internet. So why should you chose the "Nifty Date Picker"?
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.
Nifty Date Picker - Free!
Nifty Date Picker - For "ALL" Versions of MS Access
Video 1 (18:39)
In this YouTube video I demonstrate the Free "Nifty Date Picker" Suitable for "ALL" Versions of MS Access" I show you how to put together your own Nifty Date Picker Form. Why? Well a lot of code examples are only available in the later versions of MS Access (accdb). This means Some examples won't work in earlier versions of MS Access. I realised this could apply to my Nifty Date Picker it may not work in older versions of MS Access. You can download the VBA code BELOW and then construct the "Nifty Date Picker" by following the YouTube video instructions… "Hey Presto" You have a Free copy of the "Nifty Date Picker" that will work in ANY VERSION of MS Access.
Video 1 (18:39)
Buy Tony a coffee!
Nifty Date Picker - User Case Examples
Select Date & Use It In a Query
Select Date & Use It In a Query
Video 1 (6:21)
This version of the “Nifty Date Picker” demonstrates how to use the date selected in code on the form it was called from. This is a custom situation, and custom code. I also have a solution which uses a Class Module which would make the Code generic and enable it to work with any form in any situation. See my website for more information about the clsCallCalled Class Module. For the purposes of the demonstration I have added dates to the Sample file:- 12th Aug 2019 and 19th Aug 2019. If you click on either the 12th or the 19th you will see the results for those dates returned in the Query.
Video 1 (6:21)
Original OP Question on Access World Forums Here:-
More Links in the DATE MENU Below!
Option Compare Database Option Explicit 'This is the latest version of the code, Updated Jan the 27th 2020 '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 prpCtrlInitialDate = 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