Ajout d'un contrôle calendrier en dynamique sur une form, d'une manière peut conventionnelle !

Commenter

Contenu du snippet

Tous l'intérêt de ce code est de découvrir une manière peux conventionnel pour inclure un contrôle sur une form….

Le code original est de Michel Pierron (http://www.excelabo.net/trucs/ocx_optionnel) que j’ai simplifié et complété.

Source / Exemple : 


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

Conclusion :


Pour la récupération automatique de la date sélectionnée, on pourrait prévoir une procédure de sous classement de la fenêtre dtHwnd. Personnellement, j'utilise un simple timer et la procédure suivante :

Private Sub TimerCalendar_Timer()
Static Dt As String
Dim CurSysTime As SYSTEMTIME
Dim NewDT As String
TimerCalendar = False
SendMessage dtHwnd, MCM_GETCURSEL, 0&, CurSysTime
NewDT = Format(DateSerial(CurSysTime.wYear, CurSysTime.wMonth, CurSysTime.wDay), "Short Date")
If Dt = "" Then Dt = NewDT
If Dt <> NewDT Then
Me.TextBox1.Text = NewDT
Dt = NewDT
End If
TimerCalendar = True
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_patrick)