How can I create a calendar input in VBA Excel? - 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
No need to register any dll/ocx.
Easily distributable. It is FREE.
No Administratior Rights required to use this.
You can select a skin for the calendar widget. One can choose from 4 themes Venom, MartianRed, ArticBlue and GreyScale.
Choose Language to see Month/Day name. Support for 4 languages.
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

Answer 2

This is my first post here. I felt compelled to share as the loss of the calendar in Excel was a huge deal and this calendar SiddhartRout created is incredible. So, MANY thanks to #SiddhartRout for putting together this really amazing calendar. I made changes to the cosmetics but most of the underlying meat of it is still all Siddhart's work with some minor changes to meet my use case.
Cosmetic changes:
Replaced ALL of the buttons with borderless labels so it looks a lot more like the Windows 10 calendar
The border of the labels will appear/disappear on mouse enter/exit
I grayed out days that aren't for the current month. The 'gray out' is a different color that matches better for each theme.
Modified the theme colors to my liking. Added a label to click for cycling through the themes.
Changed the font to Calibri
added color change on mouse entry to month/year and arrow controls
Use this site for all of you color code needs --> RGB Color Codes
Code Changes
Optimized the Property Let Caltheme making it easier to setup and add theme colors or entirely new themes
I couldn't get the 'ESC to exit' to work reliably so i replaced it with an 'X'. It stopped crashing as much as well.
Removed the localization stuff as i'll never need it
Changing from buttons to labels required modifying some object variables where needed throughout the project
Added public variables used to store RGB values allowing use of theme colors throughout the project providing for more consistent and easier application of selected theme
User selected theme stored in the hidden sheet so it's persistent between runs
Removed the checkmark button & launch directly from a click on any day.
Screenshots of each theme:
Download link for code:
Win10ExcelCal.xlsm

Answer 3

Get international day & month names
This answer is intended to be helpful to Sid's approach regarding internationalization; so it doesn't repeat the other code parts which I consider to be clear enough building a UserForm. If wanted, I can delete it after incorporation in Vers. 4.0.
Just in addition to Sid's valid solution I demonstrate a simplified code to get international weekday and month names
- c.f. Dynamically display weekday names in native Excel language
Modified ChangeLanguage procedure in form's module frmCalendar
Sub ChangeLanguage(ByVal LCID As Long)
Dim i&
'~~> Week Day Name
For i = 1 To 7
Me.Controls("WD" & i).Caption = Left(wday(i, LCID), 2)
Next i
'~~> Month Name
For i = 1 To 12
Me.Controls("M" & i).Caption = Left(mon(i, LCID), 3)
Next i
End Sub
Called Functions in CalendarModule
These three functions could replace the LanguageTranslations() function.
Advantage: short code, less memory, easier maintenance, correct names
'(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
'(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
'(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