Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetDC& Lib "user32.dll" (ByVal hWnd&)
Private Declare PtrSafe Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&)
#Else
Private Declare Function GetDC& Lib "user32.dll" (ByVal hWnd&)
Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&)
#End If
Private LaDate As Date, LHeure As Double, OK As Boolean, BoutonJourValide As Boolean, DMini As Date, DMaxi As Date, _
AnMin2Ch As Integer, AnMax2Ch As Integer, ChgInterne As Boolean, Jour As Integer, WithEvents LabJour As MSForms.Label, _
Incomplet As Boolean, TFérié() As Boolean, SourisMinute As Boolean, SensSBnHeure As Integer, HeureEnOption As Boolean
Event Change(ByVal LaDate As Date)
Event SeFerme(ByVal AvecUnload As Boolean)
Private Const Pi×2 = 491701844 / 78256779
Rem. ——— PROPRIÉTÉS ET MÉTHODES UTILISABLES PAR LA PROGRAMMATION APPLICATIVE ———
Public Function Saisie(Optional ByVal Titre As String = "Échéance", Optional ByVal DInit, Optional ByVal Défaut = Empty)
Rem. ——— Méthode. La plus simple façon d'utiliser cet UserForm c'est de prendre l'expression UFmCalenH.Saisie(…
' Titre: Le titre de la fenêtre. Mettez y une désignation de l'évènement à dater. "Échéance" assumé.
' DInit: La date initiale. Si omis, la date en vigueur lors du dernier affichage est reprise.
' Défaut: La valeur qui sera renvoyée si l'utilisateur ferme sans faire OK. Si omis, Empty assumé.
' Remarque: Affichage modal ici (normalement un Show l'affiche non modal)
Me.Caption = Titre
If IsDate(DInit) Then
LaDate = Int(DInit): LHeure = DInit - LaDate
MontrerLaDate FocusJour:=True: MontrerLHeure
If HeureEnOption Then Set CtrBas = IIf(LHeure = 0, ImgAffPlus, ImgAffMoins)
End If
OK = False: BoutonJourValide = True
Me.Show vbModal
If OK Then Saisie = LaDate + LHeure Else Saisie = Défaut
End Function
Public Sub Coupler(ByVal Titre, ByVal Obj As MSForms.Control, _
Optional ByVal X As Double = 0, Optional ByVal Y As Double = 1)
Rem. ——— Méthode. Vous pouvez aussi coupler son affichage à un contrôle d'un UserForm.
' Titre: Le titre de la fenêtre. Il est possible de spécifier un contrôle Label.
' Obj: L'objet auquel il doit être couplé, TextBox, Label voire ComboBox.
' X et Y: Position par rapport à l'objet Obj, même principe que pour la méthode Posit.
' Assumés X:=0, Y:=1 si non précisés, donc au milieu et collé juste en dessous de Obj.
' Remarque: Affichage modal ici (normalement un Show l'affiche non modal)
Dim DInit As Date
Me.Posit Obj, X, Y: Me.Caption = Titre
On Error Resume Next: DInit = Obj: If Err Then DInit = Date
LaDate = Int(DInit): LHeure = DInit - LaDate
On Error GoTo 0: MontrerLaDate FocusJour:=True: MontrerLHeure
If HeureEnOption Then Set CtrBas = IIf(LHeure = 0, ImgAffPlus, ImgAffMoins)
OK = False: BoutonJourValide = True
Me.Show vbModal
If OK Then Obj = Format(LaDate + LHeure, "dd/mm/yyyy" & IIf(LHeure, " hh:mm", ""))
End Sub
Public Sub Posit(ByVal Obj As Object, Optional ByVal X As Double, Optional ByVal Y As Double)
Rem. ——— Méthode. Vous pouvez au préalable positionner l'UserForm par rapport à quelque chose.
' Obj: Ce par rapport à quoi vous voulez le positionner. X et Y indiqueront comment :
' X: -1: Collé au coté gauche, 0: Centré horizontalement, 1: Collé au coté droit.
' Y: -1: Collé au bord supérieur, 0: Centré verticalement, 1: Collé juste en dessous.
' Mais si la valeur absolue de X >= 1, Y:=0.9 est une valeur conventionnelle demandant
' à ce que le bord supérieur du calendrier soit aligné sur celui de Obj.
' D'autres valeurs entraineront un recouvrement partiel ou un certain éloignement.
' Mais rien ne vous empêche de rectifier encore ensuite la propriété Left ou Top
' de l'UFmCalend pour ajouter un interstice en points au bord de l'objet. Mais toujours
' avant le Show, donc avant utilisation de la méthode Saisie.
' X et Y sont facultatifs et assumés = 0. Il est donc centré sur l'objet Obj si non précisés.
Dim Lft As Double, Top As Double, Rgt As Double, Bot As Double, U As Object, UInsWidth As Single, _
UInsHeight As Single, K As Double, Wnw As Window, P As Long, Pan As Pane, Px72 As Long, Trnq As Long
If TypeOf Obj Is MSForms.Control Then
Lft = Obj.Left: Top = Obj.Top: Set U = Obj.Parent ' Normalement UserForm, Frame ou Page.
Do: UInsWidth = U.InsideWidth: UInsHeight = U.InsideHeight ' Le Multipage n'aura plus les dimensions
If TypeOf U Is MSForms.Page Then Set U = U.Parent ' intérieures, mais le Page n'avait que ça.
K = (U.Width - UInsWidth) / 2
Lft = Lft + U.Left + K
Top = Top + U.Top + U.Height - K - UInsHeight
If Not (TypeOf U Is MSForms.Frame Or TypeOf U Is MSForms.MultiPage) Then Exit Do
Set U = U.Parent: Loop
Rgt = Lft + Obj.Width: Bot = Top + Obj.Height
Else
Set Wnw = ActiveWindow: Set Pan = Wnw.ActivePane
If Intersect(Pan.VisibleRange, Obj) Is Nothing Then
For P = 1 To Wnw.Panes.Count: Set Pan = Wnw.Panes(P)
If Not Intersect(Pan.VisibleRange, Obj) Is Nothing Then Exit For
Next P
If P > Wnw.Panes.Count Then Exit Sub ' Abandon si la plage n'est visible nulle part.
End If
Px72 = GetDeviceCaps(GetDC(0), 88) ' Nombre de pixels pour 72 points.
Lft = Obj.Left: Trnq = Int(Lft / 3) * 3
Lft = Pan.PointsToScreenPixelsX(Trnq) * 72 / Px72 + (Lft - Trnq)
Px72 = GetDeviceCaps(GetDC(0), 90) ' Nombre de pixels pour 72 points.
Top = Obj.Top: Trnq = Int(Top / 3) * 3
Top = Pan.PointsToScreenPixelsY(Trnq) * 72 / Px72 + (Top - Trnq)
K = Wnw.Zoom / 100: Rgt = Lft + Obj.Width * K: Bot = Top + Obj.Height * K
End If
Me.Left = (X * (Rgt - Lft + Me.Width + 6) + Lft + Rgt - Me.Width - 6) / 2 + 3
If Abs(X) >= 1 And Y = 0.9 Then
Me.Top = Top
ElseIf Abs(X) >= 1 And Y = -0.9 Then
Me.Top = Bot - Me.Height
Else
Me.Top = (Y * (Bot - Top + Me.Height + 6) + Top + Bot - Me.Height - 6) / 2 + 3
End If
End Sub
Public Property Get Value() As Date
Rem. ——— Propriété en lecture/écriture.
Value = LaDate
End Property
Public Property Let Value(ByVal D As Date)
LaDate = D: MontrerLaDate FocusJour:=True
End Property
Public Sub Période(Optional ByVal Début, Optional ByVal DtFin)
Rem. ——— Méthode. Permet de spécifier des limites à la date qui sera saisie.
' Les deux arguments sont optionnels.
' Autre chose qu'une date revient à éliminer la limite.
' Les non spécifiés sont inchangés si possible.
If Not IsMissing(Début) Then If IsDate(Début) Then DMini = Début Else DMini = #12/31/1899#
If Not IsMissing(DtFin) Then If IsDate(DtFin) Then DMaxi = DtFin Else DMaxi = #12/31/9999#
If DMaxi < DMini Then DMini = (DMini + DMaxi) \ 2: DMaxi = DMini
End Sub
Public Property Let AnnéeMini(ByVal An2Ch As Integer)
Rem. ——— Propriété en écriture seule. Option. Plus petite année à 2 chiffres du siècle précédent.
' À défaut la décennie de 85 ans avant l'année en cours est assumée. Donc, si on ne précise
' pas cette propriété, en 2024, les années à 2 chiffres seront encore considérées de 1930
' à 2029, tandis qu'à partir de 2025 et jusqu'en 2034, elles iront de 1940 à 2039.
' Remarque: Concerne surtout les saisies au dernier champ de l'UFmCalend, la CBxAujourdhui.
AnMax2Ch = Year(Date) + (9999 - Year(Date) + An2Ch) Mod 100
AnMin2Ch = AnMax2Ch - 99
End Property
Public Property Let OptionHeure(ByVal RHS As Integer)
Rem. ——— Propriété en écriture seule.
' La saisie de l'heure est : <0: Interdite, 0: Facultative, >0: Obligatoire.
HeureEnOption = RHS = 0
ImgAffPlus.Visible = HeureEnOption
ImgAffMoins.Visible = HeureEnOption
Set CtrBas = IIf(RHS > 0, ImgAffMoins, ImgAffPlus)
End Property
Rem. ——— Fin des propriétés et méthodes utilisables par la programmation applicative.
'
' Début de la programmation Interne :
Private Sub UserForm_Initialize()
AnnéeMini = ((Year(Date) + 15) \ 10) * 10 - 100
Me.CBxAujourdhui.List = Array("Il y a 3 jours", "Avant hier", "Hier", _
"Aujourd'hui", "Demain", "Après demain", "Dans 3 jours")
DMaxi = #12/31/9999#
LaDate = Date: MontrerLaDate FocusJour:=True
End Sub
Private Sub CBnEchap_Click()
Me.Hide: RaiseEvent SeFerme(False)
End Sub
Private Sub CBnOK_Click()
If Incomplet Then MontrerJMA: Exit Sub
OK = True: Me.Hide: RaiseEvent SeFerme(False)
End Sub
Private Sub LabJour_Click(): If ChgInterne Then Exit Sub
Jour = LabJour.Caption: MontrerJMA
If BoutonJourValide Then CBnOK_Click
End Sub
Private Sub LabJ01_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 1: End Sub
Private Sub LabJ02_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 2: End Sub
Private Sub LabJ03_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 3: End Sub
Private Sub LabJ04_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 4: End Sub
Private Sub LabJ05_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 5: End Sub
Private Sub LabJ06_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 6: End Sub
Private Sub LabJ07_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 7: End Sub
Private Sub LabJ08_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 8: End Sub
Private Sub LabJ09_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 9: End Sub
Private Sub LabJ10_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 10: End Sub
Private Sub LabJ11_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 11: End Sub
Private Sub LabJ12_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 12: End Sub
Private Sub LabJ13_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 13: End Sub
Private Sub LabJ14_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 14: End Sub
Private Sub LabJ15_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 15: End Sub
Private Sub LabJ16_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 16: End Sub
Private Sub LabJ17_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 17: End Sub
Private Sub LabJ18_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 18: End Sub
Private Sub LabJ19_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 19: End Sub
Private Sub LabJ20_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 20: End Sub
Private Sub LabJ21_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 21: End Sub
Private Sub LabJ22_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 22: End Sub
Private Sub LabJ23_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 23: End Sub
Private Sub LabJ24_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 24: End Sub
Private Sub LabJ25_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 25: End Sub
Private Sub LabJ26_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 26: End Sub
Private Sub LabJ27_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 27: End Sub
Private Sub LabJ28_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 28: End Sub
Private Sub LabJ29_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 29: End Sub
Private Sub LabJ30_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 30: End Sub
Private Sub LabJ31_MouseDown(ByVal B%, ByVal S%, ByVal X!, ByVal Y!): JourParSouris 31: End Sub
Private Sub JourParSouris(ByVal J As Integer)
Jour = J: MontrerJMA: SBnJour.SetFocus
End Sub
Private Sub SBnMois_Enter()
TouchesFlèchesChangent "M", "le mois", "1 mois", "1 trimestre"
End Sub
Private Sub SBnAn_Enter()
TouchesFlèchesChangent "A", "l'année", "1 an", "3 ans"
End Sub
Private Sub SBnJour_Enter() ' Seul son évènement KeyDown est pris en charge. Caché derrière CBxAujourdhui.
TouchesFlèchesChangent "J", "le jour", "1 jour", "1 semaine"
End Sub
Private Sub SBnHeure_Enter()
TouchesFlèchesChangent "H", "l'heure", "1 minute", "5 minutes"
End Sub
Private Sub CBxAujourdhui_Enter()
CBxAujourdhui.SelStart = 0: CBxAujourdhui.SelLength = 10
TouchesFlèchesNeChangentRien
End Sub
Private Sub TBxHeure_Enter()
TouchesFlèchesNeChangentRien
End Sub
Private Sub TBxMois_Enter()
TBxMois.SelStart = 0: TBxMois.SelLength = Len(TBxMois.Text)
TouchesFlèchesNeChangentRien
End Sub
Private Sub TBxAn_Enter()
TBxAn.SelStart = 0: TBxAn.SelLength = Len(TBxAn.Text)
TouchesFlèchesNeChangentRien
End Sub
Private Sub TouchesFlèchesChangent(ByVal Lettre As String, ByVal Quoi As String, ByVal Petit As String, ByVal Grand As String)
With LabTchFlch: .Caption = " " & Lettre: .ControlTipText = "Incrémenter/décrémenter " & Quoi _
& " (Flèche " & ChrW$(&H2192) & " +" & Petit & ", " & ChrW$(&H2190) & " -" & Petit & ", " _
& ChrW$(&H2193) & " +" & Grand & ", " & ChrW$(&H2191) & " -" & Grand & ")"
.Visible = True: End With
End Sub
Private Sub TouchesFlèchesNeChangentRien()
LabTchFlch.Visible = False
End Sub
Private Sub SBnMois_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Shift = 2 Then TBxMois.SetFocus: Exit Sub
Select Case KeyCode
Case vbKeyTab: KeyCode = 0: If Shift Then SBnAn.SetFocus Else SBnJour.SetFocus
Case vbKeyDown: SBnMois.Value = SBnMois.Value + 2
Case vbKeyUp: SBnMois.Value = SBnMois.Value - 2
End Select
End Sub
Private Sub SBnAn_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Shift = 2 Then TBxAn.SetFocus: Exit Sub
Select Case KeyCode
Case vbKeyTab: KeyCode = 0: If Shift Then IIf(CtrBas Is ImgAffMoins, SBnHeure, SBnJour).SetFocus Else SBnMois.SetFocus
Case vbKeyDown: SBnAn.Value = SBnAn.Value + 2
Case vbKeyUp: SBnAn.Value = SBnAn.Value - 2
End Select
End Sub
Private Sub SBnJour_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Shift = 2 Then CBxAujourdhui.SetFocus: Exit Sub
Select Case KeyCode
Case vbKeyTab: KeyCode = 0: IIf(Shift, SBnMois, IIf(CtrBas Is ImgAffMoins, SBnHeure, SBnAn)).SetFocus: Exit Sub
Case vbKeyRight: KeyCode = 0: LaDate = LaDate + 1
Case vbKeyLeft: KeyCode = 0: LaDate = LaDate - 1
Case vbKeyDown: KeyCode = 0: LaDate = LaDate + 7
Case vbKeyUp: KeyCode = 0: LaDate = LaDate - 7
Case Else: Exit Sub
End Select
MontrerLaDate FocusJour:=True
End Sub
Private Sub TBxAn_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode <> vbKeyTab Then Exit Sub
KeyCode = 0
If Shift Then TBxMois.SetFocus Else CBxAujourdhui.SetFocus
End Sub
Private Sub TBxMois_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyBack Then ChgInterne = True: TBxMois.Text = "": ChgInterne = False: Incomplet = True: Exit Sub
If KeyCode <> vbKeyTab Or Incomplet Then Exit Sub
KeyCode = 0
If Shift Then CBxAujourdhui.SetFocus Else TBxAn.SetFocus
End Sub
Private Sub CBxAujourdhui_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode <> vbKeyTab Then Exit Sub
KeyCode = 0
MontrerJMA
If CBxAujourdhui.Text Like "*/*/*" Then
If Shift Then TBxAn.SetFocus Else TBxMois.SetFocus
Else
If Shift Then SBnMois.SetFocus Else IIf(CtrBas Is ImgAffMoins, SBnHeure, SBnAn).SetFocus
End If
End Sub
Private Sub SBnMois_Change(): If ChgInterne Then Exit Sub
MontrerJMA
End Sub
Private Sub SBnAn_Change(): If ChgInterne Then Exit Sub
MontrerJMA
End Sub
Private Sub TBxMois_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim M As Integer
If Chr$(KeyAscii) Like "#" Then
M = SBnMois * 10 + KeyAscii - &H30
If M = 111 Then M = 1
If M > 12 Then M = M Mod 100
If M > 12 Then M = M Mod 10
If M = 0 Then M = 10
KeyAscii = 0
SBnMois.Value = M
End If
End Sub
Private Sub TBxMois_Change(): If ChgInterne Then Exit Sub
Dim X As Integer, M As Integer
X = TBxMois.SelStart
For M = 1 To 12: If LCase(TBxMois.Text) Like Choose(M, "ja*", "f*", "*ar*", "av*", "*ai", _
"j*n", "j*l*", "ao*", "s*", "o*", "n*", "d*") Then Exit For
Next M: Incomplet = M > 12
If Incomplet Then Exit Sub
ChgInterne = True: SBnMois = M: MontrerJMA
If X = Len(TBxMois.Text) Then TBxMois.SelStart = 0 Else TBxMois.SelStart _
= Choose(M, 2, 1, 3, 2, 3, 4, 4, 2, 1, 1, 1, 1): If X > TBxMois.SelStart _
Then TBxMois.SelStart = X
TBxMois.SelLength = 9
End Sub
Private Sub TBxMois_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Incomplet Then Alerte "Je n'ai pas compris le mois, désolé !"
Cancel = Incomplet
End Sub
Private Sub TBxAn_Change(): If ChgInterne Then Exit Sub
Dim A As Long
If TBxAn.Text = "" Then Exit Sub
ChgInterne = True: TBxAn.Text = Right$(TBxAn.Text, 4)
On Error Resume Next: A = TBxAn.Text
If A < 1900 Then A = AnMin2Ch + (10000 + A - AnMin2Ch) Mod 100
SBnAn = A: If TBxAn.Text = SBnAn Then MontrerJMA Else Incomplet = True: ChgInterne = False
End Sub
Private Sub CBxAujourdhui_Change(): If ChgInterne Then Exit Sub
Dim DJ As Integer, S() As String, A As Long
If CBxAujourdhui.ListIndex >= 0 Then
DJ = CBxAujourdhui.ListIndex - 3
ElseIf Left$(CBxAujourdhui.Text, 6) = "Il y a" Then
DJ = -Val(Mid$(CBxAujourdhui.Text, 7))
ElseIf Left$(CBxAujourdhui.Text, 4) = "Dans" Then
DJ = Val(Mid$(CBxAujourdhui.Text, 5))
ElseIf Not CBxAujourdhui.Text Like "#*" Then
CBxAujourdhui.DropDown
Else
On Error Resume Next
S = Split(Left$(CBxAujourdhui.Text, CBxAujourdhui.SelStart), "/")
ChgInterne = True
If UBound(S) >= 0 Then Jour = Val(S(0))
If UBound(S) >= 1 Then SBnMois = Val(S(1))
If UBound(S) >= 2 Then
A = Val(S(2)) Mod 10000: If A < 1900 Then A = AnMin2Ch + (10000 + A - AnMin2Ch) Mod 100
SBnAn.Value = A: End If
ChgInterne = False
If TexteCourt(DateSerial(SBnAn, SBnMois, Jour)) <> CBxAujourdhui.Text _
Then Incomplet = True Else MontrerJMA
Exit Sub: End If
If Err.Number = 0 Then LaDate = Date + DJ: MontrerLaDate FocusJour:=False
End Sub
Private Sub MontrerJMA()
LaDate = DateSerial(SBnAn, SBnMois, Jour)
MontrerLaDate FocusJour:=False
End Sub
Private Sub MontrerLaDate(ByVal FocusJour As Boolean)
Dim DJ As Date, X As Integer, J As Integer, JFM As Integer, Y As Integer, _
LabJ As MSForms.Label, Férié As Boolean, FinMoisTraitée As Boolean
ChgInterne = True: Incomplet = False
If LaDate > DMaxi Then
Alerte DMaxi & " au plus tard !"
LaDate = DMaxi: Incomplet = True
ElseIf LaDate < DMini Then
Alerte DMini & " au plus tôt !"
LaDate = DMini: Incomplet = True
ElseIf LabMsg.Visible Then
Set CtrBas = CtrBas: End If
Jour = Day(LaDate): SBnMois = Month(LaDate): SBnAn = Year(LaDate)
DJ = DateSerial(SBnAn, SBnMois, 1): X = Weekday(DJ, 2) - 1
For J = 1 To 7: Me("LabJS" & J).BackColor = &HE8C8C2: Next J
J = 1: JFM = Day(DateSerial(SBnAn, SBnMois + 1, 0))
Do: With Me("LabSm" & Y + 1): .Caption = Right$(" " & NoDeSemISO(DJ), 3)
.Top = 42 + 18 * Y: .Visible = True: End With
Do: Set LabJ = Me(Format(J, """LabJ""00")): LabJ.Visible = True
Férié = EstFérié(DJ) Or X >= 6: LabJ.Left = 21 + 21 * X: LabJ.Top = 42 + 18 * Y
If J = Jour Then
Set LabJour = LabJ: If FocusJour Then SBnJour.SetFocus
Me("LabJS" & Weekday(DJ, 2)).BackColor = IIf(Férié, &HD6C4FF, &HFFA5&)
LabJ.SpecialEffect = fmSpecialEffectSunken
LabJ.BackColor = IIf(Férié, &HD5DCFF, &H98FFC8)
Else
LabJ.SpecialEffect = fmSpecialEffectRaised
LabJ.BackColor = IIf(Férié, &HC5A8FF, &HE8C8C2)
End If
If J = JFM Then FinMoisTraitée = True: Exit Do
J = J + 1: DJ = DJ + 1: X = (X + 1) Mod 7: Loop Until X = 0
Y = Y + 1: Loop Until FinMoisTraitée
Do While Y < 6: Me("LabSm" & Y + 1).Visible = False: Y = Y + 1: Loop
While J < 31: J = J + 1: Me(Format(J, """LabJ""00")).Visible = False: Wend
Me.TBxMois = UCase(Format(LaDate, "mmmm")): Me.TBxAn = Year(LaDate)
X = CBxAujourdhui.SelStart
If Val(CBxAujourdhui.Text) > 0 Then
CBxAujourdhui.Text = TexteCourt(LaDate)
If X < Len(CBxAujourdhui.Text) - 1 Then CBxAujourdhui.SelStart = X: CBxAujourdhui.SelLength = 10
Else
J = LaDate - Date
If Abs(J) < 3 Then Me.CBxAujourdhui.ListIndex = J + 3 Else CBxAujourdhui _
.Text = IIf(J < 0, "Il y a ", "Dans ") & Abs(J) & IIf(Abs(J) > 999, " j.", " jours")
CBxAujourdhui.SelStart = X: CBxAujourdhui.SelLength = 0
End If
ChgInterne = False
RaiseEvent Change(LaDate + LHeure)
End Sub
Private Sub Alerte(Texte As String)
LabMsg.Width = 162: LabMsg.Height = 12: LabMsg.Caption = Texte: LabMsg.Width = 162
LabMsg.Top = CtrBas.Top + 6: LabMsg.Visible = True
Me.Height = LabMsg.Top + LabMsg.Height + (Me.Height - Me.InsideHeight)
End Sub
Private Function TexteCourt(ByVal LaDate As Date) As String
Select Case SBnAn.Value
Case AnMin2Ch To AnMax2Ch: TexteCourt = Format(LaDate, "d/m/yy")
Case Else: TexteCourt = Format(LaDate, "d/m/yyyy"): End Select
End Function
Private Function NoDeSemISO(ByVal D As Date)
Dim T&: T = DateSerial(Year(D + (8 - Weekday(D - 7)) Mod 7 - 3), 1, 1)
NoDeSemISO = ((D - T - 3 + (Weekday(T - 7) + 1) Mod 7)) \ 7 + 1
End Function
Private Function EstFérié(ByVal LaDate As Date) As Boolean
Dim An As Integer, A As Integer, B As Integer, C As Integer, D As Integer, _
E As Integer, F As Integer, MPâq As Integer, Pâques As Date
On Error Resume Next
EstFérié = TFérié(LaDate): If Err = 0 Then Exit Function
On Error GoTo 0
An = Year(LaDate)
ReDim TFérié(DateSerial(An, 1, 1) To DateSerial(An + 1, 1, 0))
A = An Mod 19: B = An \ 100: C = (B - 17) \ 25
D = (B - B \ 4 - (B - C) \ 3 + 19 * A + 15) Mod 30
D = D - (D \ 28) * (1 - (D \ 28) * (29 \ (D + 1)) * ((21 - A) \ 11))
E = (An + An \ 4 + D + 2 - B + B \ 4) Mod 7: F = D - E
MPâq = 3 + (F + 40) \ 44: Pâques = DateSerial(An, MPâq, F + 28 - (MPâq \ 4) * 31)
TFérié(Pâques + 1) = True: TFérié(Pâques + 39) = True: TFérié(Pâques + 50) = True
TFérié(DateSerial(An, 1, 1)) = True: TFérié(DateSerial(An, 5, 1)) = True
TFérié(DateSerial(An, 5, 8)) = True: TFérié(DateSerial(An, 7, 14)) = True
TFérié(DateSerial(An, 8, 15)) = True: TFérié(DateSerial(An, 11, 1)) = True
TFérié(DateSerial(An, 11, 11)) = True: TFérié(DateSerial(An, 12, 25)) = True
EstFérié = TFérié(LaDate)
End Function
Private Sub CBnNow_Click()
LHeure = Now: LaDate = Int(LHeure): LHeure = Int(1440 * (LHeure - Date) + 0.5) / 1440
MontrerLaDate FocusJour:=True: MontrerLHeure
End Sub
Private Sub MontrerLHeure()
ChgInterne = True
TBxHeure.Text = Format(LHeure, "h"" h ""mm")
CkxApMidi.Value = Hour(LHeure) >= 12
PositAngul(ImgH, 13.5) = Hour(LHeure) / 12
PositAngul(ImgMin, 21.75) = Minute(LHeure) / 60
SBnHeure.Value = Int(288 * LHeure + 0.5)
ImgAffMoins.Visible = LHeure = 0 And HeureEnOption
ChgInterne = False
End Sub
Property Let PositAngul(ByVal Img As Image, ByVal R As Double, ByVal A As Double)
Img.Left = ImgCadran.Left + ImgCadran.Width / 2 + R * Sin(Pi×2 * A) - Img.Width / 2
Img.Top = ImgCadran.Top + ImgCadran.Height / 2 - R * Cos(Pi×2 * A) - Img.Height / 2
End Property
Private Sub SBnHeure_Change(): If ChgInterne Then Exit Sub
Dim HMin As Integer, Sens As Integer, JChg As Integer
HMin = Int(LHeure * 1440 + 0.5): Sens = Sgn(SBnHeure.Value * 5 - HMin)
If HMin Mod 5 <> 0 Or Sens <> SensSBnHeure Then
LHeure = (HMin + Sens) / 1440
SensSBnHeure = Sens
Else
LHeure = SBnHeure.Value / 288
End If
JChg = Int(LHeure): If JChg <> 0 Then LaDate = LaDate + JChg: MontrerLaDate False: LHeure = LHeure - JChg
MontrerLHeure
End Sub
Private Sub SBnHeure_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Shift = 2 Then TBxHeure.SetFocus: Exit Sub
Select Case KeyCode
Case vbKeyTab: KeyCode = 0: IIf(Shift, SBnJour, SBnAn).SetFocus: Exit Sub
Case vbKeyRight: KeyCode = 0: LHeure = (Int(LHeure * 1440 + 1.5) Mod 1440) / 1440: MontrerLHeure
Case vbKeyLeft: KeyCode = 0: LHeure = (Int(LHeure * 1440 + 1439.5) Mod 1440) / 1440: MontrerLHeure
Case vbKeyDown: KeyCode = 0: LHeure = (Int(LHeure * 288 + 1.5) Mod 288) / 288: MontrerLHeure
Case vbKeyUp: KeyCode = 0: LHeure = (Int(LHeure * 288 + 287.5) Mod 288) / 288: MontrerLHeure
Case Else: Exit Sub
End Select
End Sub
Private Sub TBxHeure_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case ChrW$(KeyAscii)
Case "h": TBxHeure.SelStart = Len(TBxHeure.Text): KeyAscii = 0
Case "0" To "9": Case Else: KeyAscii = 0: End Select
End Sub
Private Sub TBxHeure_Change(): If ChgInterne Then Exit Sub
Dim TJn() As String, SaisieH As Boolean, H As Integer, Min As Integer
SaisieH = TBxHeure.SelStart < InStr(TBxHeure.Text, "h")
TJn = Split(TBxHeure.Text & "h0", "h"): H = Val(TJn(0)): Min = Val(TJn(1))
H = IIf(TBxHeure.SelStart < 2 And H > 23, H \ 10, H Mod 100): If H > 23 Then H = H Mod 10
Min = Min Mod 100: If Min > 59 Then Min = Min Mod 10
LHeure = TimeSerial(H, Min, 0)
MontrerLHeure
TBxHeure.SelStart = IIf(SaisieH, InStr(TBxHeure.Text, "h") - 2, Len(TBxHeure.Text))
End Sub
Private Sub CkxApMidi_Click(): If ChgInterne Then Exit Sub
LHeure = TimeSerial(Hour(LHeure) Mod 12 - 12 * CkxApMidi.Value, Minute(LHeure), 0)
MontrerLHeure
End Sub
Private Sub ImgH_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 0 Then Exit Sub
LHeure = TimeSerial(Int(12 * AngleQuadImg(ImgH, X, Y) + 0.5) Mod 12 + 12 * -CkxApMidi.Value, Minute(LHeure), 0): MontrerLHeure
End Sub
Private Sub ImgMin_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 0 Then Exit Sub
LHeure = TimeSerial(Hour(LHeure), Int(AngleQuadImg(ImgMin, X, Y) * 60 + 0.5) Mod 60, 0): MontrerLHeure
End Sub
Private Sub ImgCadran_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button Then LHeureCadran X, Y
End Sub
Private Sub ImgCadran_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim R As Double, A As Double
R = Sqr((X - ImgCadran.Width / 2) ^ 2 + (Y - ImgCadran.Height / 2) ^ 2): If R = 0 Then Exit Sub
SourisMinute = R > 18: LHeureCadran X, Y
End Sub
Private Sub LHeureCadran(ByVal X As Single, ByVal Y As Single)
Dim A As Double: A = Atn2Q(ImgCadran.Height / 2 - Y, X - ImgCadran.Width / 2)
If SourisMinute Then
LHeure = TimeSerial(Hour(LHeure), Int(A * 60 + 0.5) Mod 60, 0)
Else
LHeure = TimeSerial(Int(12 * A + 0.5) Mod 12 + 12 * -CkxApMidi.Value, Minute(LHeure), 0)
End If
MontrerLHeure
End Sub
Private Function AngleQuadImg(ByVal Img As Image, ByVal X As Double, ByVal Y As Double) As Double
AngleQuadImg = Atn2Q(ImgCadran.Top + ImgCadran.Height / 2 - Img.Top - Y, _
Img.Left + X - ImgCadran.Left - ImgCadran.Width / 2)
End Function
Private Function Atn2Q(ByVal X As Double, ByVal Y As Double) As Double
Dim A As Double
If Y < 0 Then X = -X: Y = -Y: A = 1 Else A = 0
If X < Y Then Y = Y - X: X = X + Y: Y = Y - X: A = A + 0.5
If Y <= X Then Atn2Q = A / 2 + Atn(Y / X) / Pi×2 _
Else Atn2Q = (A + 0.5) / 2 - Atn(X / Y) / Pi×2
End Function
Private Sub ImgAffPlus_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Set CtrBas = ImgAffMoins
End Sub
Private Sub ImgAffMoins_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Set CtrBas = ImgAffPlus
End Sub
Property Set CtrBas(ByVal Ctl As MSForms.Control)
Me.Height = Ctl.Top + Ctl.Height + (Me.Height - Me.InsideHeight)
ImgAffPlus.Visible = Ctl Is ImgAffPlus And ImgAffMoins.Visible
ImgAffMoins.Visible = Ctl Is ImgAffMoins And HeureEnOption And LHeure = 0
LabMsg.Visible = False: ImgMin.Visible = Ctl Is ImgAffMoins
End Property
Property Get CtrBas() As MSForms.Control
Set CtrBas = IIf(Me.InsideHeight > ImgAffMoins.Top, ImgAffMoins, ImgAffPlus)
End Property
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then RaiseEvent SeFerme(True)
End Sub
