How can I create a calendar input in VBA Excel?

Question

Problem Statement

In VBA, three main kinds of date time controls can be used provided certain ocxs have been registered using administrator rights. These are VB6 controls and are not native to VBA environment. To install the Montview Control and Datetime Picker, we need to set a reference to Microsoft MonthView Control 6.0 (SP4) which can only be accessed by elevated registration of mscomct2.ocx. Similarly for mscal.ocx and mscomctl.ocx. Having said that, the deprecated mscal.ocx may or may not work on Windows 10.

Depending on your Windows and Office versions (32 bit or 64 bit), it can be really painful to register these ocxs.

The Monthview Control, Datetime Picker and the deprecated Calendar control look like below.

So what problem can I face if I include these in my applicaiton?

If you include them in your project and distribute them to your friends, neighbours, clients etc the application may or may not work depending on whether they have those ocx installed.

And hence it is highly advisable NOT to use them in your project

What alternative(s) do I have?

This calendar, using Userform and Worksheet, was suggested earlier and is incredibly basic.

When I saw the Windows 10 calendar which popped up when I clicked on the date and time from the system tray, I could not help but wonder if we can replicate that in VBA.

This post is about how to create a calendar widget which is not dependant on any ocx or 32bit/64bit and can be freely distributed with your project.

This is what the calendar looks like in Windows 10:

and this is how you interact with it:

Answer 1

The sample file (added at the end of the post) has a Userform, Module and a Class Module. To incorporate this into your project, simply export the Userform, Module and the Class Module from the sample file and import it into your project.

Class Module Code

In the Class Module (Let's call it CalendarClass) paste this code

Public WithEvents CommandButtonEvents As MSForms.CommandButton  '~~> Unload the form when the user presses Escape Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)     If Not f Is Nothing Then If KeyAscii = 27 Then Unload f End Sub  '~~> This section delas with showing/displaying controls '~~> and updating different labels Private Sub CommandButtonEvents_Click()     f.Label6.Caption = CommandButtonEvents.Tag      If Left(CommandButtonEvents.Name, 1) = "Y" Then         If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then             CurYear = Val(CommandButtonEvents.Caption)                             With f                 .HideAllControls                 .ShowMonthControls                  .Label4.Caption = CurYear                 .Label5.Caption = 2                  .CommandButton1.Visible = False                 .CommandButton2.Visible = False             End With         End If     ElseIf Left(CommandButtonEvents.Name, 1) = "M" Then         Select Case UCase(CommandButtonEvents.Caption)             Case "JAN": CurMonth = 1             Case "FEB": CurMonth = 2             Case "MAR": CurMonth = 3             Case "APR": CurMonth = 4             Case "MAY": CurMonth = 5             Case "JUN": CurMonth = 6             Case "JUL": CurMonth = 7             Case "AUG": CurMonth = 8             Case "SEP": CurMonth = 9             Case "OCT": CurMonth = 10             Case "NOV": CurMonth = 11             Case "DEC": CurMonth = 12         End Select          f.HideAllControls         f.ShowSpecificMonth     End If End Sub 

Module Code

In the Module (Let's call it CalendarModule) paste this code

Option Explicit  Public Const GWL_STYLE = -16 Public Const WS_CAPTION = &HC00000  #If VBA7 Then     #If Win64 Then         Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _         "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr          Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias _         "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _         ByVal dwNewLong As LongPtr) As LongPtr     #Else         Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _         "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr          Private Declare Function SetWindowLongPtr Lib "user32" Alias _         "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _         ByVal dwNewLong As LongPtr) As LongPtr     #End If      Public Declare PtrSafe Function DrawMenuBar Lib "user32" _     (ByVal hwnd As LongPtr) As LongPtr      Private Declare PtrSafe Function FindWindow Lib "user32" Alias _     "FindWindowA" (ByVal lpClassName As String, _     ByVal lpWindowName As String) As LongPtr      Private Declare PtrSafe Function SetTimer Lib "user32" _     (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _     ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr      Public Declare PtrSafe Function KillTimer Lib "user32" _     (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr      Public TimerID As LongPtr      Dim lngWindow As LongPtr, lFrmHdl As LongPtr #Else      Public Declare Function GetWindowLong _     Lib "user32" Alias "GetWindowLongA" ( _     ByVal hwnd As Long, ByVal nIndex As Long) As Long      Public Declare Function SetWindowLong _     Lib "user32" Alias "SetWindowLongA" ( _     ByVal hwnd As Long, ByVal nIndex As Long, _     ByVal dwNewLong As Long) As Long      Public Declare Function DrawMenuBar _     Lib "user32" (ByVal hwnd As Long) As Long      Public Declare Function FindWindowA _     Lib "user32" (ByVal lpClassName As String, _     ByVal lpWindowName As String) As Long      Public Declare Function SetTimer Lib "user32" ( _     ByVal hwnd As Long, ByVal nIDEvent As Long, _     ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long      Public Declare Function KillTimer Lib "user32" ( _     ByVal hwnd As Long, ByVal nIDEvent As Long) As Long      Public TimerID As Long     Dim lngWindow As Long, lFrmHdl As Long #End If  Public TimerSeconds As Single, tim As Boolean Public CurMonth As Integer, CurYear As Integer Public frmYr As Integer, ToYr As Integer  Public f As frmCalendar  Enum CalendarThemes     Venom = 0     MartianRed = 1     ArcticBlue = 2     Greyscale = 3 End Enum  Sub Launch()     Set f = frmCalendar      With f         .Caltheme = Greyscale         .LongDateFormat = "dddd dd. mmmm yyyy" '"dddd mmmm dd, yyyy" etc         .ShortDateFormat = "dd/mm/yyyy"  '"mm/dd/yyyy" or "d/m/y" etc         .Show     End With End Sub  '~~> Hide the title bar of the userform Sub HideTitleBar(frm As Object)     #If VBA7 Then         Dim lngWindow As LongPtr, lFrmHdl As LongPtr         lFrmHdl = FindWindow(vbNullString, frm.Caption)         lngWindow = GetWindowLongPtr(lFrmHdl, GWL_STYLE)         lngWindow = lngWindow And (Not WS_CAPTION)         Call SetWindowLongPtr(lFrmHdl, GWL_STYLE, lngWindow)         Call DrawMenuBar(lFrmHdl)     #Else         Dim lngWindow As Long, lFrmHdl As Long         lFrmHdl = FindWindow(vbNullString, frm.Caption)         lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)         lngWindow = lngWindow And (Not WS_CAPTION)         Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)         Call DrawMenuBar(lFrmHdl)     #End If End Sub  '~~> Start Timer Sub StartTimer()     '~~ Set the timer for 1 second     TimerSeconds = 1     TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc) End Sub  '~~> End Timer Sub EndTimer()     On Error Resume Next     KillTimer 0&, TimerID End Sub  '~~> Update Time #If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr     Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As LongLong, _     ByVal nIDEvent As LongPtr, ByVal dwTimer As LongLong)         frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)         frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)     End Sub #ElseIf VBA7 Then ' 64 bit Excel in all environments     Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _     ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)         frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)         frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)     End Sub #Else ' 32 bit Excel     Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _     ByVal nIDEvent As Long, ByVal dwTimer As Long)         frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)         frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)     End Sub #End If  '~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m) '(1) Get weekday name Function wday(ByVal wd&, ByVal lang As String) As String     ' Purpose: get weekday in "DDD" format     wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday End Function  '~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m) '(2) Get month name Function mon(ByVal mo&, ByVal lang As String) As String     ' Example call: mon(12, "1031") or mon(12, "de")     mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm") End Function  '~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m) '(3) International patterns Function cPattern(ByVal ctry As String) As String     ' Purpose: return country code pattern for above functions mon() and wday()     ' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx     ctry = LCase(Trim(ctry))     Select Case ctry         Case "1033", "en-us": cPattern = "[$-409]" ' English (US)         Case "1031", "de": cPattern = "[$-C07]" ' German         Case "1034", "es": cPattern = "[$-C0A]" ' Spanish         Case "1036", "fr": cPattern = "[$-80C]" ' French         Case "1040", "it": cPattern = "[$-410]" ' Italian         ' more ...     End Select End Function 

Userform Code

The Userform (Let's call it frmCalendar) code is too big to be posted here. Please refer to the sample file.

Screenshot

Themes

Highlights

1. No need to register any dll/ocx.
2. Easily distributable. It is FREE.
3. No Administratior Rights required to use this.
4. You can select a skin for the calendar widget. One can choose from 4 themes Venom, MartianRed, ArticBlue and GreyScale.
5. Choose Language to see Month/Day name. Support for 4 languages.
6. Specify Long and Short date formats

Sample File

Sample File

Acknowlegements @Pᴇʜ, @chrisneilsen and @T.M. for suggesting improvements.

What's New:

Bugs reported by @RobinAipperspach and @Jose fixed