Discussion :

[Jean-Philippe André]

aaah merci

[DamKre]

Merci, c'est ce dont j'avais besoin...

Juste une question : comment faire pour que la "date d'aujourd'hui" ne s'affiche plus ?

[Arkham46]

Merci, c'est ce dont j'avais besoin...

Juste une question : comment faire pour que la "date d'aujourd'hui" ne s'affiche plus ?

Bjr,

J'avais oublié ce message...

Déclaration de constantes à ajouter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
Private Const MCS_NOTODAY As Integer = &H10
Private Const MCS_NOTODAYCIRCLE As Integer = &H8

- MCS_NOTODAY masque l'affichage de la date d'"Aujourd'hui" en bas de calendrier.
- MCS_NOTODAYCIRCLE masque le cercle qui entoure la date du jour

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
       ' Crée une fenêtre de saisie de date avec calendrier
        shwnd = CreateWindowEx(0, WC_MONTHCALENDAR, vbNullString, _
                               WS_CHILD Or WS_VISIBLE Or Cal_DisplayWeeks Or IIf(IsMissing(Cal_BoldDays), 0, MCS_DAYSTATE) Or MCS_NOTODAY Or MCS_NOTODAYCIRCLE, 0, 0, 0, 0, hwnd, 0&, 0&, ByVal 0&)

[blandinais]

Bonjour
Un grand merci pour ce génial module très pratique

je n'ai trouvé aucun probleme de mise en oeuvre (access 2003)
j'utilise bien la mise en gras des week end et jour férié mais petite cerise sur le gâteau je voudrais que ces dates apparaissent également en rouge
Este ce possible

Merci pour vos suggestion
et encore bravo

[Arkham46]

j'utilise bien la mise en gras des week end et jour férié mais petite cerise sur le gâteau je voudrais que ces dates apparaissent également en rouge
Este ce possible

Ah non désolé, seule la mise en gras est possible.

[blandinais]

tant pis
merci pour ta réponse

[philben]

bonjour,

Comme Micniv, j'ai été confronté au problème du dual-screen.
En effet si l'application est affichée sur un deuxième écran, le calendrier s'affiche toujours sur le premier.

J'ai trouvé une solution parmi d'autres que je propose ici, reste à la tester sur différentes configurations et à la valider.

Le principe est de déterminer sur quel écran se trouve le contrôle puis de positionner le calendrier en fonction des coordonnées du contrôle et des coordonnées de cet écran.

• Créer un module standard et placer le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Option Explicit
 
'Référence : http://support.microsoft.com/kb/q194578/
' --------------------------------------------------------------------------
'               Copyright (C) 1998 Microsoft Corporation                   '
' --------------------------------------------------------------------------
' You have a royalty-free right to use, modify, reproduce and distribute   '
' the Sample Application Files (and/or any modified version) in any way    '
' you find useful, provided that you agree that Microsoft has no warranty, '
' obligations or liability for any Sample Application Files.               '
' --------------------------------------------------------------------------
' Written by Mike Dixon (mikedix@microsoft.com)                            '
' --------------------------------------------------------------------------
'Modifié par Philben - version 1.0
 
'Constants for the return value when finding a monitor
Const MONITOR_DEFAULTTONULL = &H0       'If the monitor is not found, return 0
Const MONITOR_DEFAULTTOPRIMARY = &H1    'If the monitor is not found, return the primary monitor
Const MONITOR_DEFAULTTONEAREST = &H2    'If the monitor is not found, return the nearest monitor
Const MONITORINFOF_PRIMARY = 1
 
'Rectangle structure, for determining
'monitors at a given position
Public Type tagMONITORRECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
 
'Structure for the position of a monitor
Private Type tagMONITORINFO
   cbSize As Long   'Size of structure
   rcMonitor As tagMONITORRECT   'Monitor rect
   rcWork As tagMONITORRECT   'Working area rect
   dwFlags As Long   'Flags
End Type
 
Private Declare Function GetMonitorInfo Lib "User32" _
                                        Alias "GetMonitorInfoA" ( _
                                        ByVal hMonitor As Long, _
                                        ByRef tMonInfo As tagMONITORINFO) As Long
 
Private Declare Function MonitorFromRect Lib "User32" ( _
                                         ByRef rc As tagMONITORRECT, _
                                         ByVal dwFlags As Long) As Long
 
'Retourne dans tDestRect les coordonnées en pixels du moniteur contenant le rectangle source
Public Function GetMonitorFromRect(ByRef tSrcRect As tagMONITORRECT, ByRef tDestRect As tagMONITORRECT) As Boolean
   On Error Resume Next
   Dim tMonitorInfo As tagMONITORINFO
   Dim lMonitor As Long, lReturn As Long
 
   'Récupère l'identifiant de l'écran contenant la majorité du rectangle défini
   lMonitor = MonitorFromRect(tSrcRect, MONITOR_DEFAULTTONEAREST)
   If lMonitor Then
      'Initialise la structure d'infos de l'écran
      tMonitorInfo.cbSize = Len(tMonitorInfo)
 
      'Récupère les infos de l'écran
      lReturn = GetMonitorInfo(lMonitor, tMonitorInfo)
      If lReturn Then
         'On ne conserve que les coordonnées de la zone de travail disponible de l'écran
         '=> barre de tâche retranchée
         tDestRect = tMonitorInfo.rcWork
         GetMonitorFromRect = True
      End If
   End If
End Function

• Dans le module du calendrier d'Arkham46, ajouter la fonction suivante

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
'Retourne les coordonnées du contrôle en pixels
Private Sub SetCtrlRectPx(ByRef tSrcRect As rect, tDestRect As tagMONITORRECT)
   With tDestRect
      .Left = tSrcRect.Left
      '.Top doit être >= 0 sinon fausse le positionnement
      If tSrcRect.Top > 0 Then .Top = tSrcRect.Top
      .Right = .Left + TwipsToPixelX(Cal_Ctrl.Width)
      .Bottom = .Top + TwipsToPixelY(Cal_Ctrl.Height)
   End With
End Sub

• Modifier la fonction <CalProc> d'Arkham46, en rouge les modifications et ajouts entourés du commentaire 'DUAL-SCREEN'

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
'---------------------------------------------------------------------------------------
' Gestion des messages de la boîte de dialogue
'---------------------------------------------------------------------------------------
' hwnd                : Handle de la fenêtre
' Msg                 : Numéro du message
' wParam et lParam    : Paramètres du message
'---------------------------------------------------------------------------------------
Private Function CalProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Dim lRect As rect, lTextRect As rect, lCalRect As rect
   Dim lScreenRect As rect
   Dim lCtrlPlcmt As WINDOWPLACEMENT
   Dim lPopupPlcmt As WINDOWPLACEMENT
   Dim lItemPlcmt As WINDOWPLACEMENT
   Dim lWrc As rect
   Dim lCrc As rect
   Dim lPt As PointAPI
   Dim lnmhdr As NMHDR
   Dim lNotify As Long, lID As Long
   Dim lSystemTimeRange(1) As SYSTEMTIME
   Dim lSystemTime As SYSTEMTIME
   Dim lDate As String
   Dim lValeur As String
   Dim lScrWitdh As Single, lScrHeight As Single
   Dim linitcc As InitCommonControlsExType
   Dim lPos As Integer
   Dim lTodayWidth As Long
   Dim lLB As LOGBRUSH
   Dim lBorder As Long
   Dim lParentForm As Object
   Dim lDaystate As NMDAYSTATE
   Dim lMonthDayState() As Long
   '*** DUAL-SCREEN
   Dim tCtrlRect As tagMONITORRECT, tScreenRect As tagMONITORRECT
   'DUAL-SCREEN ***
   Static sTextRect As rect
   Static sStaticHeight As Long    ' Hauteur de la zone de texte d'info supplémentaire
   Static sStaticWidth As Long     ' Largeur de la zone de texte d'info supplémentaire
   Static shwnd As Long, sEditHwnd As Long, sStaticHwnd As Long
   Static sFontCalendar As Long
   Static sBrush As Long
   Static sFont As Long
   Static lLastSelect(1 To 2) As Variant
   On Error Resume Next
   ' Initialisation structure nécessaire pour win98
   lCtrlPlcmt.length = Len(lCtrlPlcmt)
   lPopupPlcmt.length = Len(lPopupPlcmt)
   lItemPlcmt.length = Len(lPopupPlcmt)
   Select Case Msg
      ' NOTIFICATION
   Case WM_NOTIFY
      ' Récupère les infos dans une stucture
      lnmhdr.code = 0: lnmhdr.hwndFrom = 0: lnmhdr.idFrom = 0
      Call RtlMoveMemory(lnmhdr, ByVal lParam, Len(lnmhdr))
      ' Si la notification est envoyée par le contrôle
      If lnmhdr.hwndFrom = shwnd Then
         ' Requête d'état des jours
         If lnmhdr.code = MCN_GETDAYSTATE Then
            ' Mise en gras des jours
            Call RtlMoveMemory(lDaystate, ByVal lParam, Len(lDaystate))
            ReDim lMonthDayState(1 To lDaystate.cDayState) As Long
            Call FillMonthDayState(lDaystate, lMonthDayState)
            Call RtlMoveMemory(ByVal lDaystate.prgDayState, lMonthDayState(1), lDaystate.cDayState * 4)
         End If
         ' Si la notification correspond à un changement de la date
         If lnmhdr.code = MCN_SELCHANGE Then
            ' Récupère la date sélectionnée sur le calendrier
            SendMessage shwnd, MCM_GETCURSEL, 0&, lSystemTime
            ' Formate la date
            lDate = Format(DateSerial(lSystemTime.wYear, lSystemTime.wMonth, lSystemTime.wDay), "Short Date")
            ' Met à jour la zone de texte
            Call SendMessage(sEditHwnd, WM_SETTEXT, _
                             Len(lDate), ByVal lDate)
         End If
         ' Recherche double-click pour validation
         If lnmhdr.code = MCN_SELECT Then
            ' Récupère la date sélectionnée sur le calendrier
            SendMessage shwnd, MCM_GETCURSEL, 0&, lSystemTime
            ' Formate la date
            lDate = Format(DateSerial(lSystemTime.wYear, lSystemTime.wMonth, lSystemTime.wDay), "Short Date")
            ' Vérifie si on a cliqué deux fois sur la même date
            '   à moins d'une demi seconde d'intervalle
            If Abs(Timer - lLastSelect(1) <= 0.5) And (lLastSelect(2) = lDate) Then
               ' Cick sur OK
               Call SendMessage(hwnd, WM_COMMAND, (BN_CLICKED * &H10000) Or (IDOK And &HFFFF&), ByVal hwnd)
            End If
            lLastSelect(1) = Timer
            lLastSelect(2) = lDate
         End If
      End If
      ' Affichage de la fenêtre de dialogue
   Case WM_SHOWWINDOW
      ' Pas de bordure
      SetWindowLong hwnd, GWL_STYLE, GetWindowLong(hwnd, GWL_STYLE) Xor WS_BORDER
      ' Initialisation fenêtre static supplémentaire
      sStaticHwnd = 0
      sStaticHeight = 0
      sStaticWidth = 0
      ' Lit la taille de la fenêtre de dialogue
      Call GetWindowRect(hwnd, lRect)
      
      '*** DUAL-SCREEN
      ' Lit la taille de l'écran
      'SystemParametersInfo SPI_GETWORKAREA, 0, lScreenRect, 0
      'lScrWitdh = lScreenRect.Right - lScreenRect.Left + 1
      'lScrHeight = lScreenRect.Bottom - lScreenRect.Top + 1
      'DUAL-SCREEN ***
      
      ' Création du contrôle
      linitcc.dwSize = Len(linitcc)
      ' Type du contrôle
      linitcc.dwICC = ICC_DATE_CLASSES
      ' Initialise le contrôle
      InitCommonControlsEx linitcc
      ' Crée une fenêtre de saisie de date avec calendrier
      shwnd = CreateWindowEx(0, WC_MONTHCALENDAR, vbNullString, _
                             WS_CHILD Or WS_VISIBLE Or Cal_DisplayWeeks Or IIf(IsMissing(Cal_BoldDays), 0, MCS_DAYSTATE), 0, 0, 0, 0, hwnd, 0&, 0&, ByVal 0&)
      ' Positionne le calendrier à la date par défaut
      If IsDate(Cal_Default) And Cal_Default <> "" Then
         ' Remplit la structure SystemTime
         lSystemTime.wYear = Year(Cal_Default): lSystemTime.wMonth = Month(Cal_Default): lSystemTime.wDay = Day(Cal_Default)
         ' Sélectionne la date dans le calendrier
         SendMessage shwnd, MCM_SETCURSEL, 0&, lSystemTime
      End If
      ' Crée une police de caractères si elle n'existe pas déjà
      If sFontCalendar = 0 And (Cal_CalendarFontSize > 0 Or Cal_CalendarFontName <> "") Then
         sFontCalendar = CreateFont(-((Cal_CalendarFontSize / 72) * 96), 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, Cal_CalendarFontName)
         SendMessage shwnd, WM_SETFONT, sFontCalendar, True
      End If
      ' Taille du calendrier
      SendMessage shwnd, MCM_GETMINREQRECT, 0, lCalRect
      If lCalRect.Right = 0 Or lCalRect.Bottom = 0 Then
         lCalRect.Right = gDTPLength
         lCalRect.Bottom = gDTPLength
      End If
      ' Largeur du texte d'affichage de la date du jour
      lTodayWidth = SendMessage(shwnd, MCM_GETMAXTODAYWIDTH, 0, 0)
      ' Largeur maxi du calendrier
      If lTodayWidth > lCalRect.Right Then lCalRect.Right = lTodayWidth
      ' Ajuste la fenêtre en largeur pour afficher tout le calendrier
      ' Coordonnées de la fenêtre complète
      GetWindowRect hwnd, lWrc
      ' Taille de l'intérieur de la fenêtre
      GetClientRect hwnd, lCrc
      ' Taille de la bordure
      lBorder = (lWrc.Right - lWrc.Left - lCrc.Right + lCrc.Left)
      lRect.Right = lCalRect.Right + lBorder
      lRect.Bottom = lCalRect.Bottom + lBorder
      ' Redimensionne/Repositionne le calendrier
      Call SetWindowPos(shwnd, 0, 0, 0, _
                        lCalRect.Right, lCalRect.Bottom, SWP_NOZORDER Or SWP_FRAMECHANGED)
      ' Initialise les jours en gras pour le premier affichage du calendrier
      lDaystate.cDayState = SendMessage(shwnd, MCM_GETMONTHRANGE, 1, lSystemTimeRange(0))
      ReDim lMonthDayState(1 To lDaystate.cDayState) As Long
      lDaystate.stStart = lSystemTimeRange(0)
      FillMonthDayState lDaystate, lMonthDayState
      SendMessage shwnd, MCM_SETDAYSTATE, lDaystate.cDayState, lMonthDayState(1)
      ' Crée une zone de texte d'information
      If Cal_AdditionalInfo <> "" Then
         lValeur = Cal_AdditionalInfo
         ' Crée la fenêtre pour accueillir la zone supplémentaire
         sStaticHwnd = CreateWindowEx(0, "Static", lValeur, _
                                      WS_CHILD Or WS_VISIBLE, 0, 0, _
                                      1, 1, hwnd, 0&, 0&, ByVal 0&)
      End If
      ' Calcul la nouvelle position de la fenêtre (sous le contrôle)
      ' Formulaire parent
      Set lParentForm = Cal_Ctrl.Parent
      ' Remonte jusqu'au formulaire si contrôle dans onglets
      If TypeOf lParentForm Is Page Then
         Do
            Err.Clear
            Set lParentForm = lParentForm.Parent
            If Err.Number <> 0 Then Err.Clear: Exit Do
         Loop
      End If
      lPt.x = TwipsToPixelX(Cal_Ctrl.Left + lParentForm.CurrentSectionLeft)
      If Not Cal_Above Then
         lPt.y = TwipsToPixelY(Cal_Ctrl.Top + Cal_Ctrl.Height + lParentForm.CurrentSectionTop)
      Else
         lPt.y = TwipsToPixelY(Cal_Ctrl.Top - Cal_Ctrl.Height + lParentForm.CurrentSectionTop)
         lPt.y = lPt.y - (lRect.Bottom + 1)
      End If
      ClientToScreen lParentForm.hwnd, lPt
      Set lParentForm = Nothing
      lRect.Left = lPt.x
      lRect.Top = lPt.y
      If Cal_Above Then lRect.Top = lRect.Top - lBorder
      ' Position bouton OK
      Call GetWindowPlacement(GetDlgItem(hwnd, IDOK), lItemPlcmt)
      lItemPlcmt.rcNormalPosition.Right = lCalRect.Right / 2
      lItemPlcmt.rcNormalPosition.Left = 0
      lItemPlcmt.rcNormalPosition.Bottom = lCalRect.Bottom + lItemPlcmt.rcNormalPosition.Bottom - lItemPlcmt.rcNormalPosition.Top
      lItemPlcmt.rcNormalPosition.Top = lCalRect.Bottom
      lRect.Bottom = lRect.Bottom + lItemPlcmt.rcNormalPosition.Bottom - lItemPlcmt.rcNormalPosition.Top
      Call SetWindowPlacement(GetDlgItem(hwnd, IDOK), lItemPlcmt)
      ' Position bouton Cancel
      Call GetWindowPlacement(GetDlgItem(hwnd, IDCANCEL), lItemPlcmt)
      lItemPlcmt.rcNormalPosition.Left = lCalRect.Right / 2
      lItemPlcmt.rcNormalPosition.Right = lCalRect.Right
      lItemPlcmt.rcNormalPosition.Bottom = lCalRect.Bottom + lItemPlcmt.rcNormalPosition.Bottom - lItemPlcmt.rcNormalPosition.Top
      lItemPlcmt.rcNormalPosition.Top = lCalRect.Bottom
      Call SetWindowPlacement(GetDlgItem(hwnd, IDCANCEL), lItemPlcmt)
      ' Masque la zone de texte Static
      ShowWindow GetDlgItem(hwnd, IDSTATIC), SW_HIDE
      
      '*** DUAL-SCREEN
      ' Doit tenir dans l'écran
      'If lRect.Left + lRect.Right > lScrWitdh Then
      '   lRect.Left = lScrWitdh - lRect.Right
      'End If
      'If lRect.Top + lRect.Bottom > lScrHeight Then
      '   lRect.Top = lScrHeight - lRect.Bottom
      'End If
      SetCtrlRectPx lRect, tCtrlRect
      ' Lit la taille de l'écran
      If GetMonitorFromRect(tCtrlRect, tScreenRect) Then
         lScrWitdh = tScreenRect.Right + 1
         lScrHeight = tScreenRect.Bottom + 1
      Else
         SystemParametersInfo SPI_GETWORKAREA, 0, lScreenRect, 0
         lScrWitdh = lScreenRect.Right - lScreenRect.Left + 1
         lScrHeight = lScreenRect.Bottom - lScreenRect.Top + 1
      End If
      'Si le calendrier chevauche 2 écrans (tScreenRect.Left = 0 si non initialisé)
      If lRect.Left < tScreenRect.Left Then
         lRect.Left = tScreenRect.Left
      ElseIf lRect.Left + lRect.Right > lScrWitdh Then
         lRect.Left = lScrWitdh - lRect.Right
      End If
      'Si le calendrier est trop haut (tScreenRect.Top = 0 si non initialisé)
      If lRect.Top < tScreenRect.Top Then
         lRect.Top = tScreenRect.Top
      ElseIf lRect.Top + lRect.Bottom > lScrHeight Then
         lRect.Top = lScrHeight - lRect.Bottom
      End If
      'DUAL-SCREEN ***
      
      ' Repositionne la fenêtre de dialogue
      Call SetWindowPos(hwnd, HWND_TOPMOST, lRect.Left, lRect.Top, lRect.Right, lRect.Bottom, SWP_NOZORDER Or SWP_FRAMECHANGED)
      ' COULEUR DES CONTROLES
   Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC, WM_CTLCOLORBTN, WM_CTLCOLOREDIT
      ' Couleurs dans la fenêtre de dialogue
      If Msg = WM_CTLCOLOREDIT Then    ' Contrôle zone de texte
         ' Lorsqu'on passe sur le contrôle EDIT on conserve son handle pour usage ultérieure
         sEditHwnd = lParam
         ' Masque la zone d'édition
         ShowWindow lParam, SW_HIDE
      ElseIf Msg = WM_CTLCOLORSTATIC Or Msg = WM_CTLCOLORDLG Then    ' Fond de la fenêtre
         If lParam = sStaticHwnd Then
            ' Repositionne la zone de texte d'information sous le contrôle
            Call GetWindowPlacement(GetDlgItem(hwnd, IDOK), lCtrlPlcmt)
            Call SetWindowPos(sStaticHwnd, 0, GetSystemMetrics(SM_CYCAPTION), lCtrlPlcmt.rcNormalPosition.Bottom, sStaticWidth, sStaticHeight, SWP_NOZORDER Or SWP_FRAMECHANGED)
            ' Change la couleur du texte d'information
            If Cal_TextForeColor <> -1 Then Call SetTextColor(wParam, Cal_TextForeColor)
            ' Crée une police de caractères si elle n'existe pas déjà
            If sFont = 0 Then
               sFont = CreateFont(-((Cal_TextFontSize / 72) * 96), 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, Cal_TextFontName)
            End If
            ' Sélectionne la police de caractères (wparam est le contexte d'affichage)
            SelectObject wParam, sFont
            ' Calcul la taille du texte et agrandit la popup
            If sStaticHeight = 0 Then
               GetClientRect hwnd, lRect
               lTextRect.Right = lRect.Right - lRect.Left
               lTextRect.Bottom = 0
               DrawTextEx wParam, Cal_AdditionalInfo, Len(Cal_AdditionalInfo), lTextRect, DT_CALCRECT Or DT_WORDBREAK, ByVal 0
               sStaticHeight = lTextRect.Bottom
               sStaticWidth = lRect.Right
               GetWindowRect hwnd, lRect
               lRect.Bottom = lRect.Bottom + sStaticHeight

               '*** DUAL-SCREEN
               ' Lit la taille de l'écran
               'SystemParametersInfo SPI_GETWORKAREA, 0, lScreenRect, 0
               'lScrWitdh = lScreenRect.Right - lScreenRect.Left + 1
               'lScrHeight = lScreenRect.Bottom - lScreenRect.Top + 1

               With tCtrlRect
                  .Left = lRect.Left
                  .Top = lRect.Top
                  .Right = lRect.Right
                  .Bottom = lRect.Bottom
               End With
               If GetMonitorFromRect(tCtrlRect, tScreenRect) Then
                  lScrHeight = tScreenRect.Bottom - tScreenRect.Top + 1
               Else
                  SystemParametersInfo SPI_GETWORKAREA, 0, lScreenRect, 0
                  lScrHeight = lScreenRect.Bottom - lScreenRect.Top + 1
               End If
               'DUAL-SCREEN ***

               If lRect.Bottom > lScrHeight Then
                  lRect.Top = lScrHeight - lRect.Bottom + lRect.Top
                  lRect.Bottom = lScrHeight
               End If
               ' Repositionne la fenêtre de dialogue
               If Cal_Above Then
                  lRect.Top = lRect.Top - sStaticHeight
                  lRect.Bottom = lRect.Bottom - sStaticHeight
               End If
               ' Repositionne la fenêtre de dialogue
               If Cal_Above Then
                  lRect.Top = lRect.Top - sStaticHeight
                  lRect.Bottom = lRect.Bottom - sStaticHeight
               End If
               Call SetWindowPos(hwnd, HWND_TOPMOST, lRect.Left, lRect.Top, lRect.Right - lRect.Left, lRect.Bottom - lRect.Top, SWP_NOZORDER Or SWP_FRAMECHANGED)
               ' Repositionne la fenêtre de texte
               Call SetWindowPos(sStaticHwnd, 0, 0, 0, sStaticWidth, sStaticHeight, SWP_NOMOVE Or SWP_NOZORDER Or SWP_FRAMECHANGED)
            End If
         End If
         ' Change la couleur de fond du texte d'information
         If Cal_TextBackColor <> -1 Then Call SetBkColor(wParam, Cal_TextBackColor)
         ' Crée une brosse pour le fond si elle n'existe pas déjà
         If sBrush = 0 Then
            ' Définition de la couleur
            lLB.lbColor = Cal_TextBackColor
            ' Crée une brosse de la couleur choisi
            sBrush = CreateBrushIndirect(lLB)
         End If
         ' Affectation de la brosse
         CalProc = sBrush
         ' On sort de la fonction pour éviter que le code standard rechange les couleurs
         Exit Function
      End If
      ' FERMETURE DE LA FENETRE
   Case WM_DESTROY
      ' Supression de la police de caractères
      DeleteObject sFontCalendar
      sFontCalendar = 0    ' Initialisation pour prochaine exécution
      ' Supression de la police de caractères
      DeleteObject sFont
      sFont = 0    ' Initialisation pour prochaine exécution
      ' Suppression de la brosse
      DeleteObject sBrush
      sBrush = 0    ' Initialisation pour prochaine exécution
      ' Supprime le contrôle
      DestroyWindow shwnd
      ' Stoppe la surveillance des messages de la fenêtre
      Call SetWindowLong(hwnd, GWL_WNDPROC, Cal_OldProc)
      ' Initialise les variables
      sEditHwnd = 0
      shwnd = 0
   End Select
   ' Appelle la fonction de gestion des messages d'origine
   CalProc = CallWindowProc(Cal_OldProc, hwnd, Msg, wParam, ByVal lParam)
End Function

Merci de me dire si ça fonctionne... (en dual-screen ou non)

Philippe

[Arkham46]

bonjour,

Comme Micniv, j'ai été confronté au problème du dual-screen.
En effet si l'application est affichée sur un deuxième écran, le calendrier s'affiche toujours sur le premier.

J'ai trouvé une solution parmi d'autres que je propose ici, reste à la tester sur différentes configurations et à la valider.

[...]

Merci de me dire si ça fonctionne... (en dual-screen ou non)

Philippe

J'ai enfin pu tester sur un double-écran, ça marche très bien!

Quand j'aurai un peu de temps, j'intégrerai les ajouts au module.

[akrimi08]

Merci beaucoup pour ce module de calendrier et encore une fois merci bcp

[Anne1969]

Vraiment super...ça marche impeccablement sur Access 2003 !

[voldorak]

Bonjour à tous,
je pense avoir trouvé au travers de ce post la solution à mon problème (merci à l'auteur ), mais les liens semblent ne plus fonctionner (ou pas chez moi ??)
Quelqu'un pourrait il me faire passer le code, svp, pour que je teste çà ?
Merci à tous
Nicolas

[Arkham46]

bjr,

[...] mais les liens semblent ne plus fonctionner (ou pas chez moi ??)

le serveur ftp est actuellement indisponible
retentez plus tard

[voldorak]

Bien noté, merci Arkham !
Je m'obstinerai donc jusqu'à l'obtention de ce fichier
Bonne journée

[voldorak]

çà marche parfaitement !!
Un grand merci à l'auteur !

Plus qu'à tester le module des jours fériés et çà sera parfait

[User]

Bonjour à tous,

Salut Thierry ,

Une petite question pour le futur, qui concerne l'utilisation de ton module sur office 2010 en 64 bits.

Est-ce que ton module de calendrier fonctionne toujours étant donné qu'il utilise des API ?

Sinon, comptes-tu en faire une mise à jour ?

[Arkham46]

Salut User et les autres.

Une petite question pour le futur, qui concerne l'utilisation de ton module sur office 2010 en 64 bits.

Est-ce que ton module de calendrier fonctionne toujours étant donné qu'il utilise des API ?

Ah ben non là ça ne marche pas sur une version 2010 64bits.

Sinon, comptes-tu en faire une mise à jour ?

Oui j'essaye de tout réécrire compatible 64 bits, petit à petit.
Mais à ce jour je n'ai pas encore de version 64 bits pour tester, donc j'écris en aveugle et ce module n'est pas le plus simple.
J'attendrai pour ce module soit d'avoir office 2010, soit d'avoir une foule en délire qui me réclame une mise à jour.

[User]

Merci,

Salut User et les autres.
...
J'attendrai pour ce module soit d'avoir office 2010, soit d'avoir une foule en délire qui me réclame une mise à jour.

D'un autre côté, l'avantage du module, c'est que tu peux le remplacer aisément par un simple copié collé dans les anciennes applis qui l'utilise

[domik]

Bonjour, Arkham46

J’utilise déjà depuis pas mal de temps ce super calendrier v0.2 : (20/06/07)

Mais aujourd’hui je suis confronté à un p’tit problème :
Dans un formulaire j’ai 2 contrôles « Datdeb » et « Datfin »

Je vérifie les 2 dates saisies via le calendrier après avoir choisi un nom ds une liste par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Modifiable777_Click()
On Error GoTo Err_Commande777_Click
           If IsNull(Me.Datdeb) Or IsNull(Me.Datfin) Then
            MsgBox "Entrez une Date de début et une date de fin !", vbExclamation, ""
            Me.Modifiable777 = Null
            Me.Datdeb.SetFocus
            Else
                If (Me.Datdeb) > (Me.Datfin) Then
                MsgBox "La date de début est supérieure à la date de fin !", vbExclamation, ""
                Me.Datdeb = Null
                Me.Datfin = Null
                Me.Datdeb.SetFocus
                Else
 
    Dim stDocName As String
    Dim stLinkCriteria As String
    stDocName = "toto"
    DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Commande777_Click:
    Exit Sub
Err_Commande777_Click:
    MsgBox Err.Description
    Resume Exit_Commande777_Click
 
            End If
                End If
End Sub

Tout se passe correctement sauf si le jour de la date de début est supérieur au jour de la date de fin
exemple:

Dated = 20/01/2011 et Datfin = 30/03/2011 ok pas de msg

Dated = 20/01/2011 et Datfin = 01/04/2011 la Msgbox "La date de début est supérieure à la date de fin " s’affiche

Le mois et l’année ne sont pas pris en compte apparemment

Je ne rencontre pas ce problème si je saisie les dates manuellement
constatez vous la même chose , y a t-il une correction à apporter?

merci
je travaillle avec access 2003

[User]

Salut Domik,

Il traite tes zones de texte Dated et Datfin comme du texte:

1er exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dated = 20/01/2011 et Datfin = 30/03/2011 ok pas de msg

"20/01/2011" < "30/03/2011"

2ème exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dated = 20/01/2011 et Datfin = 01/04/2011 la Msgbox "La date de début est supérieure à la date de fin " s’affiche

"20/01/2011" > "01/04/2011"

Il faut utiliser la fonction de conversion CDate ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
If CDate(Me.Datdeb) > CDate (Me.Datfin) Then
...

A+

[domik]

merci User