How can I create the Windows 10 calendar in VBA Excel?
13
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:
excel vba
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
add a comment |
13
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:
excel vba
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
2
This question is being discussed on meta
– BrakNicku
9 hours ago
add a comment |
13
13
13
6
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:
excel vba
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
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:
excel vba
excel vba
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
edited 1 hour ago
Siddharth Rout
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
asked 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
115k14153206
2
This question is being discussed on meta
– BrakNicku
9 hours ago
add a comment |
2
This question is being discussed on meta
– BrakNicku
9 hours ago
2
2
This question is being discussed on meta
– BrakNicku
9 hours ago
This question is being discussed on meta
– BrakNicku
9 hours ago
add a comment |
2 Answers
2
active
oldest
votes
17
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
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.
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
Some of yourPrtSavedeclarations are wrong and don't work. Some of theLongs have to be converted toLongPtr(actually all the pointers, but not the rest of theLong!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)
– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations toLongPtrtoo.
– Pᴇʜ
14 hours ago
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
|
show 5 more comments
-1
PtrSafe stuff should be fixed like that I think (someone should test if 32bit still works as I couldn't test it).
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
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public TimerID 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
#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
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bitdeclarationof SetTime is incorrect -uElapseis not a pointer - it's declared as UINT, so it should beLongin both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.
– Comintern
20 mins ago
add a comment |
Your Answer
StackExchange.ifUsing("editor", function () {
StackExchange.using("externalEditor", function () {
StackExchange.using("snippets", function () {
StackExchange.snippets.init();
});
});
}, "code-snippets");
StackExchange.ready(function() {
var channelOptions = {
tags: "".split(" "),
id: "1"
};
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function() {
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled) {
StackExchange.using("snippets", function() {
createEditor();
});
}
else {
createEditor();
}
});
function createEditor() {
StackExchange.prepareEditor({
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: true,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: 10,
bindNavPrevention: true,
postfix: "",
imageUploader: {
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
},
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
});
}
});
draft saved
draft discarded
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f54650417%2fhow-can-i-create-the-windows-10-calendar-in-vba-excel%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
2 Answers
2
active
oldest
votes
2 Answers
2
active
oldest
votes
active
oldest
votes
active
oldest
votes
17
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
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.
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
Some of yourPrtSavedeclarations are wrong and don't work. Some of theLongs have to be converted toLongPtr(actually all the pointers, but not the rest of theLong!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)
– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations toLongPtrtoo.
– Pᴇʜ
14 hours ago
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
|
show 5 more comments
17
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
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.
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
Some of yourPrtSavedeclarations are wrong and don't work. Some of theLongs have to be converted toLongPtr(actually all the pointers, but not the rest of theLong!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)
– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations toLongPtrtoo.
– Pᴇʜ
14 hours ago
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
|
show 5 more comments
17
17
17
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
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.
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
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
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.
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
edited 1 hour ago
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
answered 15 hours ago
Siddharth RoutSiddharth Rout
115k14153206
115k14153206
Some of yourPrtSavedeclarations are wrong and don't work. Some of theLongs have to be converted toLongPtr(actually all the pointers, but not the rest of theLong!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)
– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations toLongPtrtoo.
– Pᴇʜ
14 hours ago
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
|
show 5 more comments
Some of yourPrtSavedeclarations are wrong and don't work. Some of theLongs have to be converted toLongPtr(actually all the pointers, but not the rest of theLong!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)
– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations toLongPtrtoo.
– Pᴇʜ
14 hours ago
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
Some of your
PrtSave declarations are wrong and don't work. Some of the Longs have to be converted to LongPtr (actually all the pointers, but not the rest of the Long!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)– Pᴇʜ
15 hours ago
Some of your
PrtSave declarations are wrong and don't work. Some of the Longs have to be converted to LongPtr (actually all the pointers, but not the rest of the Long!). Check it up at cadsharp.com/docs/Win32API_PtrSafe.txt. • Idea: Push it to github maybe? You could checkin the exported userform/module files so it could be easily forked. Nice work :)– Pᴇʜ
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
Thanks. :) Do not have 64 bit excel so couldn't check it. Will try and get my hands on one or if you have then you can check it for me?
– Siddharth Rout
15 hours ago
1
1
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
Nice! I'm actually starting a project next week where I could use this!
– Zac
15 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations to
LongPtr too.– Pᴇʜ
14 hours ago
@SiddharthRout Added it as an answer. You should test if 32bit still works since I had to change some variable declarations to
LongPtr too.– Pᴇʜ
14 hours ago
1
1
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
embedding your code in mine and testing... need some time @Pᴇʜ
– Siddharth Rout
13 hours ago
|
show 5 more comments
-1
PtrSafe stuff should be fixed like that I think (someone should test if 32bit still works as I couldn't test it).
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
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public TimerID 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
#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
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bitdeclarationof SetTime is incorrect -uElapseis not a pointer - it's declared as UINT, so it should beLongin both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.
– Comintern
20 mins ago
add a comment |
-1
PtrSafe stuff should be fixed like that I think (someone should test if 32bit still works as I couldn't test it).
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
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public TimerID 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
#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
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bitdeclarationof SetTime is incorrect -uElapseis not a pointer - it's declared as UINT, so it should beLongin both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.
– Comintern
20 mins ago
add a comment |
-1
-1
-1
PtrSafe stuff should be fixed like that I think (someone should test if 32bit still works as I couldn't test it).
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
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public TimerID 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
#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
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
PtrSafe stuff should be fixed like that I think (someone should test if 32bit still works as I couldn't test it).
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
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public TimerID 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
#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
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
edited 14 hours ago
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
answered 14 hours ago
PᴇʜPᴇʜ
22.5k52850
22.5k52850
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bitdeclarationof SetTime is incorrect -uElapseis not a pointer - it's declared as UINT, so it should beLongin both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.
– Comintern
20 mins ago
add a comment |
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bitdeclarationof SetTime is incorrect -uElapseis not a pointer - it's declared as UINT, so it should beLongin both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.
– Comintern
20 mins ago
1
1
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Now we need someone to test the 64bit part
– Siddharth Rout
13 hours ago
Your 64 bit
declaration of SetTime is incorrect - uElapse is not a pointer - it's declared as UINT, so it should be Long in both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.– Comintern
20 mins ago
Your 64 bit
declaration of SetTime is incorrect - uElapse is not a pointer - it's declared as UINT, so it should be Long in both versions. There's a handy cheat sheet here if you don't have the Windows SDK headers installed.– Comintern
20 mins ago
add a comment |
draft saved
draft discarded
Thanks for contributing an answer to Stack Overflow!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
To learn more, see our tips on writing great answers.
draft saved
draft discarded
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f54650417%2fhow-can-i-create-the-windows-10-calendar-in-vba-excel%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
2
This question is being discussed on meta
– BrakNicku
9 hours ago