1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
' Tout le code n'est pas de moi, et j'ai oublié la source. J'en suis désolé
Option Explicit
Private Sub UserForm_Initialize()
Const WS_CHILD& = &H40000000, MONTHCAL_CLASS$ = "SysMonthCal32", _
MCM_FIRST& = &H1000&, MCM_GETMINREQRECT& = (MCM_FIRST + 9&), _
SWP_SHOWWINDOW& = &H40&, MCS_NOTODAY& = &H10&, _
MCS_NOTODAYCIRCLE& = &H8&, ICC_DATE_CLASSES& = &H100&
Const SM_CYCAPTION = 4
Dim CalRect As RECT, LeTop&, LeLeft&, hwnd&, Marge&, CvtPtPixel!, _
IniCtrl As InitCommonControlsExType, PtCal As PointAPI
LeTop = 5&
Marge = 5&
CvtPtPixel = 3 / 4
hwnd = FindWindow(vbNullString, Me.Caption)
'Création du controle calendrier
With IniCtrl
.dwSize = Len(IniCtrl)
.dwICC = ICC_DATE_CLASSES
End With
InitCommonControlsEx IniCtrl
mWnd = CreateWindowEx(0&, MONTHCAL_CLASS, vbNullString, _
WS_CHILD Or MCS_NOTODAY Or MCS_NOTODAYCIRCLE _
, 0&, 0&, 0&, 0&, hwnd, 0&, 0&, 0&)
'Ajustement de la position du control calendrier
SendMessage mWnd, MCM_GETMINREQRECT, 0&, CalRect
SetWindowPos mWnd, 0, LeTop, Marge, CalRect.Right + Marge, _
CalRect.Bottom + LeTop, SWP_SHOWWINDOW
'Ajustement de la position des boutons
GetWindowRect mWnd, CalRect
With CalRect
PtCal.x = .Right
PtCal.y = .Top
End With
ScreenToClient hwnd, PtCal
LeLeft = PtCal.x * CvtPtPixel + Marge
With CommandButton1
.Left = LeLeft
.Top = Marge
End With
'Ajustement de la taille du UserForm
With CalRect
PtCal.x = .Top
PtCal.y = .Bottom
End With
ScreenToClient hwnd, PtCal
With Me
.StartUpPosition = 0
.CommandButton1.Height = PtCal.y * CvtPtPixel - Marge
.CommandButton1.Width = 23
.CommandButton1.Caption = "OK"
.Width = CommandButton1.Width + LeLeft + Marge * 2
.Height = (PtCal.x + PtCal.y) * CvtPtPixel + Marge
.Top = PtCur.y * CvtPtPixel
.Left = PtCur.x * CvtPtPixel
End With
End Sub
Private Sub CommandButton1_Click()
Const MCM_FIRST& = &H1000&, MCM_GETCURSEL& = (MCM_FIRST + 1&)
Dim LeTime As SYSTEMTIME
'Récuperer la date sélectionnée
SendMessage mWnd, MCM_GETCURSEL, 0&, LeTime
With LeTime
Dim laDate As Date
laDate = Format(DateSerial(.wYear, .wMonth, .wDay), "Short Date") '"dd-mmm-yy") '"Short Date")
Me.Hide
ActiveCell = CDate(laDate):
ActiveCell(1, 2).Select:
End With
Unload Me
End Sub
Private Sub UserForm_Terminate()
'Détruire le control calendrier
DestroyWindow mWnd
End Sub |
