mjhjmtu

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:

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.

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