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