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 “Nifty 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 Nifty 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 datepicker that will work in your version (ANY VERSION) of MS Access.
Be Aware!
Now I’ve completed this video explaining how to build the form yourself, I will remove the FREE download option. That is, I will remove the ability to get the code for free with a coupon code. So this is your last chance to get a copy of my Nifty Access Calendar Form – Date Picker!
Video 1 (18:39)
… …
Option Compare Database Option Explicit 'This is the latest version of the code, created December the 12th 2018 '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 dDatePassedIn As Date) Dim intInitialDay As Integer intInitialDay = DatePart("d", dDatePassedIn) 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 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) 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