How can I create the Windows 10 calendar in VBA Excel? [on hold]

  • A+
Category:Languages

Unlike in VB6, there exists no native calendar widget in VBA. The only widgets I can find are very environment-dependent; they require registering mscal.ocx or mscomct2.ocx and so only work with 32-bit versions of Office.

This calendar, using Userform and Worksheet, is incredibly basic and has a dissimilar UI to that of Windows 10.

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 is what the calendar looks like in Windows 10:

How can I create the Windows 10 calendar in VBA Excel? [on hold]

and this is how you interact with it:

How can I create the Windows 10 calendar in VBA Excel? [on hold]

So how do we create that in VBA Excel?

 


I have added a sample file at the end of the post. 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.

The sample file has a Userform, Module and a Class Module.

Class Module Code

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

' '~~> This section is used for handling Commandbutton Control Array '  Public WithEvents CommandButtonEvents As MSForms.CommandButton  '~~> Unload the form when the user presses Escape Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)     If KeyAscii = 27 Then Unload frmCalendar End Sub  '~~> This section delas with showing/displaying controls '~~> and updating different labels Private Sub CommandButtonEvents_Click()     frmCalendar.Label6.Caption = CommandButtonEvents.Tag      If Left(CommandButtonEvents.Name, 1) = "Y" Then         If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then             CurYear = Val(CommandButtonEvents.Caption)              With frmCalendar                 .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          frmCalendar.HideAllControls         frmCalendar.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  '~~> 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  Sub Launch()     frmCalendar.Show End Sub 

Userform Code

And this code goes in the Userform (Let's call it frmCalendar)

Option Explicit  Private TimerID As Long, TimerSeconds As Single, tim As Boolean Dim curDate As Date Dim i As Long Dim thisDay As Integer, thisMonth As Integer, thisYear As Integer Dim CBArray() As New CalendarClass  Private Sub UserForm_Initialize()     '~~> Hide the Title Bar     HideTitleBar Me      '~~> Set the color of controls     Me.BackColor = RGB(69, 69, 69)     Frame1.BackColor = RGB(69, 69, 69)     Label2.ForeColor = RGB(182, 182, 182)     Label3.ForeColor = RGB(66, 156, 227)     Label6.ForeColor = RGB(66, 156, 227)     Label4.ForeColor = RGB(223, 223, 223)     CommandButton1.ForeColor = RGB(201, 201, 201)     CommandButton2.ForeColor = RGB(201, 201, 201)      '~~> Create a command button control array so that     '~~> when we press escape, we can unload the userform     Dim CBCtl As Control      i = 0      For Each CBCtl In Me.Controls         If TypeOf CBCtl Is MSForms.CommandButton Then             i = i + 1             ReDim Preserve CBArray(1 To i)             Set CBArray(i).CommandButtonEvents = CBCtl         End If     Next CBCtl     Set CBCtl = Nothing      '~~> Set the Time     StartTimer      '~~> Set the Date (Tuesday, February 12, 2019)     Label3.Caption = Format(Date, "dddd mmmm dd, yyyy")     Label6.Caption = Format(Date, "dd/mm/yyyy")      curDate = Date      thisDay = Day(Date): thisMonth = Month(Date): thisYear = Year(Date)      CurYear = Year(Date): CurMonth = Month(Date)      '~~> Populate this months calendar     PopulateCalendar curDate End Sub  '~~> Insert Selected date Private Sub DTINSERT_Click()     If Len(Trim(Label6.Caption)) = 0 Then         MsgBox "Please select a date first", vbCritical, "No date selected"         Exit Sub     End If     '~~> Change the code here to insert date where ever you want     MsgBox Label6.Caption, vbInformation, "Date selected" End Sub  '~~> Stop timer in the terminate event Private Sub UserForm_Terminate()     EndTimer End Sub  '~~> Unload the form when user presses escape Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)     If KeyAscii = 27 Then Unload Me End Sub  '~~> UP Button Private Sub CommandButton1_Click()     Select Case Label5.Caption         Case 1 '~~> When user presses the up button when the dates are displayed             curDate = DateSerial(CurYear, CurMonth, 0)              '~~> Check if date is >= 1/1/1919             If curDate >= DateSerial(1919, 1, 1) Then                 '~~> Populate prev months calendar                 PopulateCalendar curDate             End If         Case 2 '<~~ Do nothing         Case 3 '~~> When user presses the up button when the Year Range is displayed             If frmYr > 1919 Then                 ResetBlueColor                  Dim NewToYr As Integer                  ToYr = frmYr - 1                 NewToYr = frmYr - 1                  For i = 1 To 12                     Me.Controls("Y" & i).Caption = ""                 Next i                  For i = 12 To 1 Step -1                     If Not NewToYr < 1919 Then                         With Me.Controls("Y" & i)                             .Caption = NewToYr                              If NewToYr = thisYear Then                                 .BackStyle = fmBackStyleOpaque                                 .BackColor = &H8000000D                             End If                              .Visible = True                              NewToYr = NewToYr - 1                         End With                     End If                 Next i                  frmYr = NewToYr + 1                 Label4.Caption = (NewToYr + 1) & " - " & ToYr             End If     End Select End Sub  '~~> Down Button Private Sub CommandButton2_Click()     Select Case Label5.Caption         Case 1 '~~> When user presses the down button when the dates are displayed             curDate = DateAdd("m", 1, DateSerial(CurYear, CurMonth, 1))              '~~> Check if date is <= 31/12/2119             If curDate <= DateSerial(2119, 12, 31) Then                 '~~> Populate prev months calendar                 PopulateCalendar curDate             End If         Case 2 '<~~ Do nothing         Case 3 '~~> When user presses the down button when the Year Range is displayed             frmYr = Val(Split(Label4.Caption, "-")(0))             ToYr = Val(Split(Label4.Caption, "-")(1))              If ToYr < 2119 Then                 ResetBlueColor                  Dim NewFrmYr As Integer                  frmYr = ToYr + 1                 NewFrmYr = ToYr + 1                  For i = 1 To 12                     Me.Controls("Y" & i).Caption = ""                 Next i                  For i = 1 To 12                     If NewFrmYr < 2119 Then                         With Me.Controls("Y" & i)                             .Caption = NewFrmYr                              If NewFrmYr = thisYear Then                                 .BackStyle = fmBackStyleOpaque                                 .BackColor = &H8000000D                             End If                              .Visible = True                              NewFrmYr = NewFrmYr + 1                         End With                     ElseIf NewFrmYr = 2119 Then                         With Me.Controls("Y" & i)                             .Caption = NewFrmYr                             .Visible = True                             NewFrmYr = NewFrmYr + 1                         End With                     End If                 Next i                  If NewFrmYr = 2119 Then ToYr = NewFrmYr Else ToYr = NewFrmYr - 1                 Label4.Caption = frmYr & " - " & ToYr             End If     End Select End Sub  '~~> Populate the calendar for a specific month Sub PopulateCalendar(d As Date)     '~~> Get the day of 1st of the month     Dim m As Integer, y As Integer     Dim i As Integer, j As Integer     Dim LastDay As Integer, NextCounter As Integer, PrevCounter As Integer     Dim dtOne As Date, dtLast As Date, dtNext As Date      ResetBlueColor      For i = 1 To 42         Me.Controls("CB" & i).ForeColor = RGB(255, 255, 255)     Next i      CurYear = Year(d)     CurMonth = Month(d)      m = Month(d): y = Year(d)      dtOne = DateSerial(y, m, 1)     dtLast = DateSerial(Year(dtOne), Month(dtOne), 0)     dtNext = DateAdd("m", 1, DateSerial(Year(dtOne), Month(dtOne), 1))      Select Case Weekday(dtOne, 0)         Case 7: CB1.Caption = 1: NextCounter = 2: PrevCounter = 0         Case 1: CB2.Caption = 1: NextCounter = 3: PrevCounter = 1         Case 2: CB3.Caption = 1: NextCounter = 4: PrevCounter = 2         Case 3: CB4.Caption = 1: NextCounter = 5: PrevCounter = 3         Case 4: CB5.Caption = 1: NextCounter = 6: PrevCounter = 4         Case 5: CB6.Caption = 1: NextCounter = 7: PrevCounter = 5         Case 6: CB7.Caption = 1: NextCounter = 8: PrevCounter = 6     End Select      LastDay = Val(Format(Excel.Application.WorksheetFunction.EoMonth(dtOne, 0), "dd"))      For i = 2 To LastDay         Me.Controls("CB" & NextCounter).Caption = i         Me.Controls("CB" & NextCounter).Tag = DateSerial(Year(d), Month(d), i)           If i = thisDay And Month(d) = thisMonth And Year(d) = thisYear Then             With Me.Controls("CB" & NextCounter)                 .BackStyle = fmBackStyleOpaque                 .BackColor = &H8000000D             End With         End If          NextCounter = NextCounter + 1     Next i      j = 1      If NextCounter < 43 Then         For i = NextCounter To 42             With Me.Controls("CB" & i)                 .Caption = j                 .Tag = DateSerial(Year(dtNext), Month(dtNext), j)                 .ForeColor = RGB(132, 132, 132)             End With             j = j + 1         Next i     End If      LastDay = Val(Format(dtLast, "dd"))      If PrevCounter > 1 Then         For i = PrevCounter To 1 Step -1             With Me.Controls("CB" & i)                 .Caption = LastDay                 .Tag = DateSerial(Year(dtLast), Month(dtLast), LastDay)                 .ForeColor = RGB(132, 132, 132)             End With             LastDay = LastDay - 1         Next i     ElseIf PrevCounter = 1 Then         With Me.Controls("CB1")             .Caption = LastDay             .Tag = DateSerial(Year(dtLast), Month(dtLast), LastDay)             .ForeColor = RGB(132, 132, 132)         End With     End If      Label4.Caption = Format(d, "mmmm yyyy")      CB1.SetFocus '<~~ Required so that user can press esc to quit End Sub  '~~> Hide all controls Sub HideAllControls()      DTINSERT.Visible = False      Label6.Visible = False       For i = 1 To 7         With Me.Controls("WD" & i)             .Visible = False             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i       For i = 1 To 42         With Me.Controls("CB" & i)             .Visible = False             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i       For i = 1 To 12         With Me.Controls("M" & i)             .Visible = False             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i       For i = 1 To 12         With Me.Controls("Y" & i)             .Visible = False             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i End Sub  '~~> Show the months when user clicks on the date label Sub ShowMonthControls()      For i = 1 To 12         Me.Controls("M" & i).Visible = True          If i = thisMonth Then             With Me.Controls("M" & i)                 .BackStyle = fmBackStyleOpaque                 .BackColor = &H8000000D             End With         End If      Next i End Sub  '~~> Show the details for specific month Sub ShowSpecificMonth()     DTINSERT.Visible = True     Label6.Visible = True      For i = 1 To 42         Me.Controls("CB" & i).Visible = True     Next i      Label4.Caption = Format(DateSerial(CurYear, CurMonth, 1), "mmm yyyy")     Label5.Caption = 1      CommandButton1.Visible = True     CommandButton2.Visible = True      PopulateCalendar DateSerial(CurYear, CurMonth, 1) End Sub  '~~> Removes the blue color from current day/month/year Sub ResetBlueColor()      For i = 1 To 42         With Me.Controls("CB" & i)             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i       For i = 1 To 12         With Me.Controls("Y" & i)             .BackStyle = fmBackStyleTransparent             .BackColor = &H8000000F         End With      Next i End Sub  '~~> Handles the month to year to year slab display Private Sub Label4_Click()      Select Case Label5.Caption         Case 1             HideAllControls              Label4.Caption = Split(Label4.Caption)(1)             Label5.Caption = 2              ShowMonthControls              CommandButton1.Visible = False             CommandButton2.Visible = False         Case 2             HideAllControls             CommandButton1.Visible = True             CommandButton2.Visible = True              ToYr = Val(Label4.Caption)             frmYr = ToYr - 11              If frmYr < 1919 Then frmYr = 1919              Label4.Caption = frmYr & " - " & ToYr             Label5.Caption = 3              For i = 1 To 12                 Me.Controls("Y" & i).Caption = ""             Next i              For i = 12 To 1 Step -1                 If Not ToYr < 1919 Then                     With Me.Controls("Y" & i)                         .Caption = ToYr                         .Visible = True                          If ToYr = thisYear Then                             With Me.Controls("Y" & i)                                 .BackStyle = fmBackStyleOpaque                                 .BackColor = &H8000000D                             End With                         End If                          ToYr = ToYr - 1                     End With                 End If             Next i              Label5.Caption = 3         Case 3 'Do Nothing      End Select End Sub 

Screenshot

This is how the calendar looks like when you run the form

How can I create the Windows 10 calendar in VBA Excel? [on hold]

How can I create the Windows 10 calendar in VBA Excel? [on hold]

How can I create the Windows 10 calendar in VBA Excel? [on hold]

Sample File

The sample file can be downloaded from HERE

Acknowlegement

I would like to thank @Pᴇʜ for taking out time to test the code and suggest improvements for the 64 bit version. I have incorporated his suggestions in the sample file.

Comment

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: