'*****************************************************************************************************
' ___ _____ _____ _____
' // \\ // // // // // //\ / \\
' //__// //__// //__ //__ //__ // \/ \\
' // \\ // // // // // // \\
'// // // // //____ //____ //____ // \\
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'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 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 GetClientRect Lib "user32" (ByVal hWnd As LongPtr, wMsg As Any) 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 DestroyWindow Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetDpiForWindow Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Private Type MCHITTESTINFO
cbSize As Long
ptX As Long
ptY As Long
uHit As Long
st(0 To 7) As Integer
End Type
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
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 Frame1_Click()
End Sub
Private Sub UserForm_Activate()
Const DTM_SETSYSTEMTIME = &H1002
Dim tm(0 To 9) As Integer, dDate As Date, rect(0 To 3) As Long, PPX As Double
PPX = 1 / (GetDpiForWindow(Application.hWnd) / 72)
Frame1.Move 0, 0
Frame1.Enabled = False
GetClientRect Frame1.[_GethWnd], rect(0)
DatePickeHwnd = CreateWindowExA(0, "SysMonthCal32", vbNullString, &H50000000, 0, 0, rect(2), rect(3), Frame1.[_GethWnd], 0, 0, 0)
Me.Width = rect(2) * PPX
Me.Height = ((rect(3) + 18) * PPX)
If IsDate(dat) Then
dDate = Me.dat
tm(0) = Year(dat):
tm(1) = Month(dat):
tm(3) = Day(dat)
SendMessageW DatePickeHwnd, DTM_SETSYSTEMTIME, 0, VarPtr(tm(0))
End If
Select Case TypeName(obj)
Case "Range": placementRange obj
Case "TextBox", "Label", "CommandButton": placementUF obj
Case "Shape": placementActivXsheets obj
End Select
End Sub
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.ptX
MapWindowPoints 0, Frame1.[_GethWnd], hit.ptX, 1
SendMessageW DatePickeHwnd, &H100E, 0, VarPtr(hit)
If (hit.uHit And &H20001) = &H20001 Then
dat = DateSerial(hit.st(0), hit.st(1), hit.st(3))
If DatePickeHwnd <> 0 Then DestroyWindow DatePickeHwnd
Me.Hide
ElseIf hit.uHit = &H10002 Then
Frame1.Enabled = True 'édition de l'année
SendMessageW DatePickeHwnd, &H201, 0, (hit.ptY * &H10000) + hit.ptX
Frame1.Enabled = False
Else
SendMessageW DatePickeHwnd, &H201, 0, (hit.ptY * &H10000) + hit.ptX
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 = GetDpiForWindow(Application.hWnd) / 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 = GetDpiForWindow(Application.hWnd) / 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