AJOUT D'UN CONTRÔLE CALENDRIER EN DYNAMIQUE SUR UNE FORM, D'UNE MANIÈRE PEUT CONVENTIONNELLE !

'
' Source original : (Michel Pierron) http://www.excelabo.net/trucs/ocx_optionnel
'
' Pour tester, mettre dans en bas d’une form une TextBox nommé TextBox1, et deux boutons nommés CmdSET et CmdGET.
'
'

 
 Option Explicit
 
 Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (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 Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 Private Declare Sub InitCommonControls Lib "comctl32" ()

' MonthCal Messages
 Private Const MCM_FIRST = &H1000
 Private Const MCM_GETCURSEL = (MCM_FIRST + 1)
 Private Const MCM_SETCURSEL = (MCM_FIRST + 2)
 Private Const MCM_SETCOLOR = (MCM_FIRST + 10)
 Private Const MCM_GETCOLOR = (MCM_FIRST + 11)
 Private Const MCM_SETFIRSTDAYOFWEEK = (MCM_FIRST + 15)
 Private Const MCM_GETFIRSTDAYOFWEEK = (MCM_FIRST + 16)

' MonthCal Styles
 Private Const MCS_MULTISELECT = &H2
 Private Const MCS_WEEKNUMBERS = &H4
 Private Const MCS_NOTODAYCIRCLE = &H8
 Private Const MCS_NOTODAY = &H10

' MonthCal Color
 Private Const MCSC_BACKGROUND = 0   ' the background color (between months)
 Private Const MCSC_TEXT = 1         ' the dates
 Private Const MCSC_TITLEBK = 2      ' background of the title
 Private Const MCSC_TITLETEXT = 3
 Private Const MCSC_MONTHBK = 4      ' background within the month cal
 Private Const MCSC_TRAILINGTEXT = 5 ' the text color of header & trailing days
  
  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 dtHwnd As Long

Private Sub Form_Load()
  InitCommonControls
  dtHwnd = CreateWindowEx(0, "SysMonthCal32", vbNullString, &H50000000 + MCS_WEEKNUMBERS, 40, 10, 200, 200, Me.hWnd, 0&, 0&, ByVal 0&)
  SendMessage dtHwnd, MCM_SETCOLOR, MCSC_BACKGROUND, ByVal &HE0E0E0
  SendMessage dtHwnd, MCM_SETCOLOR, MCSC_TITLEBK, ByVal RGB(46, 210, 50)
End Sub

Private Sub CmdGET_Click()
 Dim CurSysTime As SYSTEMTIME
  SendMessage dtHwnd, MCM_GETCURSEL, 0&, CurSysTime
  Me.TextBox1.Text = Format(DateSerial(CurSysTime.wYear, CurSysTime.wMonth, CurSysTime.wDay), "Short Date")
End Sub

Private Sub CmdSET_Click()
 Dim CurSysTime As SYSTEMTIME
  On Error Resume Next
   CurSysTime.wYear = Year(CDate(Me.TextBox1.Text))
   CurSysTime.wMonth = Month(CDate(Me.TextBox1.Text))
   CurSysTime.wDay = Day(CDate(Me.TextBox1.Text))
  On Error GoTo 0
  SendMessage dtHwnd, MCM_SETCURSEL, 0&, CurSysTime
End Sub

Private Sub Form_QueryClose(Cancel As Integer, CloseMode As Integer)
 DestroyWindow dtHwnd
End Sub