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 |
Partager