'*****************************************************************************************************
' ___ _____ _____ _____
' // \\ // // // // // //\ / \\
' //__// //__// //__ //__ //__ // \/ \\
' // \\ // // // // // // \\
'// // // // //____ //____ //____ // \\
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'userform calendrier utilisant les api pour utiliser le calendrier de windows
'dont l'ocx ne fonctionne pas sur excel 64 bit
'auteurs:
' _ @Rheeem sur exceldownload
' _ @Patricktoulon sur exceldownloads
'Version 2.0
'Date Version : 03/01/2026
'Dans cet exercice nous trouvons le moyen de rendre responsif la window de type SysMonthCal32)créée dynamiquement
'----------------------------------------------------------------------------------------
'exemple au click droit sur cellules
'Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' Cancel = True
' Target = Calendrier.DateValueX(Target)
'End Sub
'exemple avec une shape
'Sub Rectangleàcoinsarrondis1_Cliquer()
' ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text = Calendrier.DateValueX(ActiveSheet.Shapes(Application.Caller))
'End Sub
'exemple d'appels pour les controls dans les userforms
'Private Sub CommandButton1_Click()
' CommandButton1.Caption = Calendrier.DateValueX(CommandButton1)
'End Sub
'Private Sub Label1_Click()
' Label1.Caption = Calendrier.DateValueX(Label1)
'End Sub
'Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If Button = 2 Then TextBox1.Value = Calendrier.DateValueX(TextBox1)
'End Sub
'****************************************************************************************************
Option Explicit
Private Declare PtrSafe Function CreateWindowExA Lib "user32" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, _
ByVal hInstance As LongPtr, ByVal lpParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessageW Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function MapWindowPoints Lib "user32" ( _
ByVal hWndFrom As LongPtr, ByVal hWndTo As LongPtr, _
lpPoints As Any, ByVal cPoints As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As Any) As Long
Private Declare PtrSafe Function GetDpiForWindow Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long
Private Type POINT_API
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SystemTime
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type MCHITTESTINFO
cbSize As Long
pt As POINT_API
uHit As Long
st As SystemTime
End Type
Private Const MCM_FIRST = &H1000
Private Const MCM_SETCURSEL = MCM_FIRST + 2
Private Const MCM_GETMINREQRECT = MCM_FIRST + 9
Private Const MCM_HITTEST = MCM_FIRST + 14
Private Const MCM_GETMAXTODAYWIDTH = MCM_FIRST + 21
Private Const MCHT_CALENDARDATE = &H20001
Private Const MCHT_TITLEMONTH = &H10002
Private Const MCS_WEEKNUMBERS = 4
Private Const MCS_NOTODAYCIRCLE = 8
Private Const MCS_NOTODAY = &H10
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_LBUTTONDOWN = &H201
Private Const SWP_NOMOVE = &H2 ' on bloque la fentre ou on la positionne
Private DatePickeHwnd As LongPtr 'handle de la fenêtre de type (SysMonthCal32)
Public dat As Date 'variable date servant de propriété pour la classe userform calendrier(lecture/ecriture)
Public obj As Object
'callback pour la classe calendrier
Public Function DateValueX(Optional obj As Object = Nothing)
With Calendrier
If Not obj Is Nothing Then
Set .obj = obj
Select Case TypeName(obj)
Case "Range"
If IsDate(obj.Value) Then .dat = CDate(obj.Value) Else dat = Date
Case "TextBox"
If IsDate(obj.Text) Then .dat = CDate(obj.Text) Else dat = Date
Case "Label", "CommandButton"
If IsDate(obj.Caption) Then .dat = CDate(obj.Caption) Else dat = Date
Case "Shape", "DrawingObject"
If IsDate(ActiveSheet.DrawingObjects(obj.Name).Text) Then .dat = CDate(ActiveSheet.DrawingObjects(obj.Name).Text) Else dat = Date
Case Else: Date = Date 'au cas ou l'appelant n'est pas identifié
End Select
Else: dat = Date
End If
If obj Is Nothing Then Me.StartUpPosition = 1
Show
If TypeName(obj) = "Shape" Then
DateValueX = Format(dat, "dd/mm/yyyy")
Else
DateValueX = dat
End If
Unload Calendrier
End With
End Function
Private Sub UserForm_Initialize()
Dim Rc As RECT, H As Long, W As Long, TodayWidth As Long, PPX As Double
PPX = 72 / AppDpi
Frame1.Enabled = False
DatePickeHwnd = CreateWindowExA(0, "SysMonthCal32", vbNullString, _
WS_CHILD Or WS_VISIBLE, 0, 0, 0, 0, _
Frame1.[_GethWnd], 0, 0, 0)
SendMessageW DatePickeHwnd, MCM_GETMINREQRECT, 0, VarPtr(Rc)
TodayWidth = SendMessageW(DatePickeHwnd, MCM_GETMAXTODAYWIDTH, 0, 0)
If TodayWidth > Rc.Right Then: Rc.Right = TodayWidth
SetWindowPos DatePickeHwnd, 0, 0, 0, Rc.Right, Rc.Bottom, SWP_NOMOVE
Frame1.Move 0, 0, Rc.Right * PPX, Rc.Bottom * PPX
Move 0, 5000, Frame1.Width + (Width - InsideWidth), Frame1.Height + (Height - InsideHeight)
End Sub
Private Sub UserForm_Activate()
Dim tm As SystemTime
If IsDate(dat) Then
tm.wYear = Year(dat):
tm.wMonth = Month(dat):
tm.wDay = Day(dat)
SendMessageW DatePickeHwnd, MCM_SETCURSEL, 0, VarPtr(tm)
End If
Select Case TypeName(obj)
Case "Range": placementRange obj
Case "TextBox", "Label", "CommandButton": placementUF obj
Case "Shape": placementActivXsheets obj
End Select
If Left = 0 Then
Move (Application.Width - Width) / 2, (Application.Height - Height) / 2
End If
End Sub
Private Function AppDpi() As Long
AppDpi = 96
On Error Resume Next
AppDpi = GetDpiForWindow(Application.hWnd)
End Function
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim hit As MCHITTESTINFO
hit.cbSize = Len(hit)
hit.uHit = 0
GetCursorPos hit.pt
MapWindowPoints 0, Frame1.[_GethWnd], hit.pt, 1
SendMessageW DatePickeHwnd, MCM_HITTEST, 0, VarPtr(hit)
If (hit.uHit And MCHT_CALENDARDATE) = MCHT_CALENDARDATE Then
dat = DateSerial(hit.st.wYear, hit.st.wMonth, hit.st.wDay)
Me.Hide
ElseIf hit.uHit = MCHT_TITLEMONTH Then
Frame1.Enabled = True 'édition de l'année
SendMessageW DatePickeHwnd, WM_LBUTTONDOWN, 0, (hit.pt.Y * &H10000) + hit.pt.X
Frame1.Enabled = False
Else
SendMessageW DatePickeHwnd, WM_LBUTTONDOWN, 0, (hit.pt.Y * &H10000) + hit.pt.X
End If
End Sub
'******************************************************************************************
'Fonction de placement du calendarier issu du calendar 5.0 by patricktoulon
Private Sub placementUF(obj As Object)
If Not obj Is Nothing Then
Dim Lft As Double, Top As Double, P As Object, PInsWidth As Double, PInsHeight As Double
Dim k As Double
' Normalement Page, Frame ou UserForm
Lft = obj.Left
Top = obj.Top
Set P = obj.Parent
Do
' Le Page en est pourvu, mais pas le Multipage.
PInsWidth = P.InsideWidth
PInsHeight = P.InsideHeight
' Prend le Multipage, car le Page est sans positionnement.
If TypeOf P Is MSForms.Page Then Set P = P.Parent
k = (P.Width - PInsWidth) / 2
Lft = (Lft + P.Left + k)
Top = (Top + P.Top + P.Height - k - PInsHeight)
If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
Set P = P.Parent
Loop
Me.Left = Lft + ((obj.Width / 2) * 2) ' a gauche en top
Me.Top = Top + ((obj.Height / 2) * 0)
If Me.Left > Application.Left + Application.Width - Me.Width Then Me.Left = Application.Left + Application.Width - Me.Width - 15
If Me.Top > Application.Top + Application.Height - Me.Height Then Me.Top = Application.Top + Application.Height - Me.Height - 15
End If
End Sub
Function GetPaneIndexByPosition(obj)
Dim panindex&, i&
With ActiveWindow
panindex = .ActivePane.Index
If Intersect(.ActivePane.VisibleRange, obj) Is Nothing Then
For i = 1 To .Panes.Count
If Not Intersect(.Panes(i).VisibleRange, obj) Is Nothing Then panindex = i: Exit For
Next
End If
End With
GetPaneIndexByPosition = panindex
End Function
Private Function placementRange(obj As Object)
If obj Is Nothing Then Exit Function
Dim L1#, T1#, PtoPx#, Z#, cel As Range, panindex&
With ActiveWindow
Z = .Zoom / 100
PtoPx = AppDpi / 72 'coeff point to pixel
panindex = GetPaneIndexByPosition(obj)
'exit si la cellule injecté n'est pas vible a l'ecran
L1 = (.Panes(panindex).PointsToScreenPixelsX((obj.Left)) / PtoPx) + (((obj.Width * Z))) 'placement partie mobile
T1 = (.Panes(panindex).PointsToScreenPixelsY((obj.Top)) / PtoPx)
End With
If L1 > Application.Left + Application.Width - Me.Width Then L1 = Application.Left + Application.Width - Me.Width - 15
If T1 > Application.Top + Application.Height - Me.Height Then T1 = Application.Top + Application.Height - Me.Height - 15
With Me
.Left = L1
.Top = T1
End With
End Function
Private Function placementActivXsheets(obj As Object)
If obj Is Nothing Then Exit Function
Dim L1#, T1#, PtoPx#, Z#
With ActiveWindow
Z = .Zoom / 100
PtoPx = AppDpi / 72 'coeff point to pixel
L1 = (.ActivePane.PointsToScreenPixelsX(obj.Left) / PtoPx) + (((obj.Width * Z) / 2) * 2)
T1 = (.ActivePane.PointsToScreenPixelsY(obj.Top) / PtoPx) + (((obj.Height * Z) / 2) * 0)
If L1 > Application.Left + Application.Width - Me.Width Then L1 = Application.Left + Application.Width - Me.Width - 15
If T1 > Application.Top + Application.Height - Me.Height Then T1 = Application.Top + Application.Height - Me.Height - 15
With Me
.Left = L1
.Top = T1
End With
End With
End Function
