VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fmSTD_Calendrier ClientHeight = 3390 ClientLeft = 45 ClientTop = 375 ClientWidth = 3990 OleObjectBlob = "fmSTD_Calendrier.frx":0000 StartUpPosition = 2 'CenterScreen End Attribute VB_Name = "fmSTD_Calendrier" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit ' ========================================================================================================= ' Vous pouvez adapter ces paramètres v (tous ces paramètres ont été ajouté suite à des demandes du forum . ' ---------------------------------- v . Private Const ClicDateOkAuto = True ' True=saisie au clic sur jour False sera à confirmer avec BoutonOK . Private Const ChoixAffJrsCal% = 3 ' 1=aff.jours du mois sélectionné 2+mois suivant 3+mois précédent . Private Const NoDuPremJourSem% = 1 ' 1=Lundi à 7=Dimanche . Private Const SensDuCalendrier$ = ">" ' ">"=Gauche>Droite(classique) "<"=Gauche 3 Then Msg$ = "ChoixAffJrsCal" If VarType(ClicDateOkAuto) <> vbBoolean Then Msg$ = "ClicDateOkAuto" If NoDuPremJourSem% < 1 Or NoDuPremJourSem% > 7 Then Msg$ = "NoDuPremJourSem%" If SensDuCalendrier$ <> ">" And SensDuCalendrier$ <> "<" Then Msg$ = "SensDuCalendrier$" If VarType(FormatDateUserSurCell) <> vbBoolean Then Msg$ = "FormatDateUserSurCell" On Error Resume Next: Err.Clear dat = Format(Date, FormatDateUser$): If Err Then Msg$ = "FormatDateUser$" On Error GoTo 0: Err.Clear If Msg$ > "" Then DateSelectUser = "": Me.Hide: MsgBox "La Constante suivante n'est pas valide !?" & vbLf & Msg$, vbCritical, "Erreur Paramètre": Exit Sub If AnneeNVM > 0 Then '#NVM# Util_Roland CalBaseAnneeMini = AnneeNVM: CalBaseAnneeMaxi = AnneeNVM Else CalBaseAnneeMini = 1901: CalBaseAnneeMaxi = 2200 End If ' INIT 1'jour sem et sens du calendrier Dim JR As Variant, No% JR = Array("", "Lun", "Mar", "Mer", "Jeu", "Ven", "Sam", "Dim", "Lun", "Mar", "Mer", "Jeu", "Ven", "Sam") No = NoDuPremJourSem: J = 0 With Me If SensDuCalendrier$ = "<" Then 'jours sem sens DD + Nos.Tag (classique) .LbLun = JR(No): .LbMar = JR(No + 1): .LbMer = JR(No + 2): .LbJeu = JR(No + 3) .LbVen = JR(No + 4): .LbSam = JR(No + 5): .LbDim = JR(No + 6) For i = 1 To 42: .Controls("J" & i).Tag = i: Next End If End With '1/3 TEST SI APPEL pour Dates Cellule Mini/Maxi (tests limites déjà effectués!) If DateSelectUser = "DatMinMax" Then DatCal = CalDateDEBUT: CalPremANNEE = Year(CalDateDEBUT): CalDernANNEE = Year(CalDateFIN) If IsDate(ActiveCell) Then 'si date sur cellule !? DatCal = ActiveCell If DatCal < CalDateDEBUT Or DatCal > CalDateFIN Then MsgBox "Date sur cellule= " & Format(DatCal, FormatDateUser$) & vbLf & vbLf & "Limites des Dates Début/Fin" & vbLf & Format(CalDateDEBUT, FormatDateUser$) & " au " & Format(CalDateFIN, FormatDateUser$), vbExclamation, "" DatCal = CalDateDEBUT End If End If If DatCal < CalDateDEBUT Or DatCal > CalDateFIN Then DatCal = CalDateDEBUT Me.Caption = "Saisie entre " & Format(CalDateDEBUT, FormatDateUser$) & " et " & Format(CalDateFIN, FormatDateUser$) 'me.caption Else 'autres tests... CalPremANNEE = CalBaseAnneeMini: CalDernANNEE = CalBaseAnneeMaxi CalDateDEBUT = "01/01/" & Trim(CalPremANNEE): CalDateFIN = "31/12/" & Trim(CalDernANNEE) '2/3 TEST SI c'est date fin> "Date fin ? /début=jj/mm/aaaa" (ici me.Caption reste avec son contenu) If Left(Me.Caption, 18) = "Date début ? /fin=" Then If IsDate(DateSelectUser) Then DatCal = CDate(DateSelectUser) Else DatCal = Date ElseIf Left(Me.Caption, 18) = "Date fin ? /début=" Then If IsDate(Mid(Me.Caption, 19)) Then 'si oui reprend la date de début DatCal = Mid(Me.Caption, 19): CalDateDEBUT = DatCal: CalPremANNEE = Year(DatCal) If IsDate(DateSelectUser) Then If CDate(DateSelectUser) > CalDateDEBUT Then DatCal = CDate(DateSelectUser) Else 'erreur sortie Msg$ = "La Date Début/Fin placée dans Calendrier.Caption est invalide !?" & vbLf & vbLf & Me.Caption: GoTo TraitErr End If '3/3 TEST si c'est Date Divers ou Cellule dans DatCal (ici me.Caption = "") ElseIf IsDate(DateSelectUser) Then DatCal = CDate(DateSelectUser): Me.Caption = "" Else 'sinon erreur!? Msg$ = "La date placée dans DateSelectUser est invalide ou absente !?" & vbLf & vbLf & DateSelectUser: GoTo TraitErr End If End If '... suite fin des tests init dates ... DateSelectUser = "" ' CalBaseAnneeMaxi Or CalDernANNEE > CalBaseAnneeMaxi Then Msg$ = "L'année de votre date est supérieure à la date maxi du calendrier !?": GoTo TraitErr dat = Date 'place la date en cours sur le bouton LbAujourdhui et si on peut la sélectionner !? LbAujourdhui.Caption = Format(dat, "dddd") & vbLf & Format(dat, FormatDateUser$) If dat < CalDateDEBUT Or dat > CalDateFIN Then LbAujourdhui.Enabled = False ' init liste annee/mois du calendrier CbAnnee.Clear: For i = CalPremANNEE To CalDernANNEE: CbAnnee.AddItem i: Next CbMois.Clear: For i = 1 To 12: CbMois.AddItem Choose(i, "Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre"): Next ' CalendrierMiseAjour DatCal: Exit Sub TraitErr: DateSelectUser = "": Me.Hide: MsgBox Msg$, vbCritical, "Erreur Date": Exit Sub End Sub ' routine quand clic bouton . Private Sub BoutonJour(BoutonJour As Control) If BoutonJour.Enabled = False Then Exit Sub Dim NoJour, NoMois, NoBouton, NoAn NoBouton = Val(BoutonJour.Tag) 'no bouton NoJour = BoutonJour.Caption 'jour NoMois = CbMois.ListIndex + 1 'mois NoAn = CbAnnee.Value If NoBouton - NoJour < 0 Then 'si saisie un jour du mois précédent If NoMois > 1 Then NoMois = NoMois - 1 ElseIf NoAn > CalPremANNEE Then 'si=1 déduit 1année NoMois = 12: NoAn = NoAn - 1 End If ElseIf NoBouton - NoJour > 8 Then 'si saisie un jour du mois suivant If NoMois < 12 Then NoMois = NoMois + 1 ElseIf NoAn < CalDernANNEE Then 'si=12 ajoute 1année NoMois = 1: NoAn = NoAn + 1 End If End If CalDateSELECT = NoJour & "/" & NoMois & "/" & NoAn CalendrierMiseAjour CalDateSELECT If AnneeNVM > 0 Then '#NVM# Util_Roland BoutonOK = True 'confirme auto après clic sur jour Else BoutonOK = ClicDateOkAuto 'confirme auto après clic sur jour End If End Sub 'sans module de classe pour simplifier l'incorporation du calendrier 'pour créer le code des 42 Sub Bouton dans la fenêtre d'exécution 'For I = 1 To 42:Print "Private Sub J" & I & "_Click(): BoutonJour J" & I & ": End Sub":Next Private Sub J1_Click(): BoutonJour J1: End Sub Private Sub J2_Click(): BoutonJour J2: End Sub Private Sub J3_Click(): BoutonJour J3: End Sub Private Sub J4_Click(): BoutonJour J4: End Sub Private Sub J5_Click(): BoutonJour J5: End Sub Private Sub J6_Click(): BoutonJour J6: End Sub Private Sub J7_Click(): BoutonJour J7: End Sub Private Sub J8_Click(): BoutonJour J8: End Sub Private Sub J9_Click(): BoutonJour J9: End Sub Private Sub J10_Click(): BoutonJour J10: End Sub Private Sub J11_Click(): BoutonJour J11: End Sub Private Sub J12_Click(): BoutonJour J12: End Sub Private Sub J13_Click(): BoutonJour J13: End Sub Private Sub J14_Click(): BoutonJour J14: End Sub Private Sub J15_Click(): BoutonJour J15: End Sub Private Sub J16_Click(): BoutonJour J16: End Sub Private Sub J17_Click(): BoutonJour J17: End Sub Private Sub J18_Click(): BoutonJour J18: End Sub Private Sub J19_Click(): BoutonJour J19: End Sub Private Sub J20_Click(): BoutonJour J20: End Sub Private Sub J21_Click(): BoutonJour J21: End Sub Private Sub J22_Click(): BoutonJour J22: End Sub Private Sub J23_Click(): BoutonJour J23: End Sub Private Sub J24_Click(): BoutonJour J24: End Sub Private Sub J25_Click(): BoutonJour J25: End Sub Private Sub J26_Click(): BoutonJour J26: End Sub Private Sub J27_Click(): BoutonJour J27: End Sub Private Sub J28_Click(): BoutonJour J28: End Sub Private Sub J29_Click(): BoutonJour J29: End Sub Private Sub J30_Click(): BoutonJour J30: End Sub Private Sub J31_Click(): BoutonJour J31: End Sub Private Sub J32_Click(): BoutonJour J32: End Sub Private Sub J33_Click(): BoutonJour J33: End Sub Private Sub J34_Click(): BoutonJour J34: End Sub Private Sub J35_Click(): BoutonJour J35: End Sub Private Sub J36_Click(): BoutonJour J36: End Sub Private Sub J37_Click(): BoutonJour J37: End Sub Private Sub J38_Click(): BoutonJour J38: End Sub Private Sub J39_Click(): BoutonJour J39: End Sub Private Sub J40_Click(): BoutonJour J40: End Sub Private Sub J41_Click(): BoutonJour J41: End Sub Private Sub J42_Click(): BoutonJour J42: End Sub ' . ' initialise le calendrier . Private Sub CalendrierMiseAjour(D As Date) Dim CaseJR As Control, DateJR As Date, DateJ1 As Date, JrVisible As Boolean, JrEnabled As Boolean Dim MoisSelect%, AnneSelect%, NoJour%, NoSemISO%, Mois%, Anne%, JX% 'init CalDateSELECT et test limites CalDateSELECT = D If CalDateSELECT < CalDateDEBUT Then CalDateSELECT = CalDateDEBUT If CalDateSELECT > CalDateFIN Then CalDateSELECT = CalDateFIN MoisSelect = Month(CalDateSELECT) AnneSelect = Year(CalDateSELECT) DateJ1 = "01/" & MoisSelect & "/" & AnneSelect '1'du mois pour boucle CaseJR Dim v%: v = NoDuPremJourSem + 1: If v > 7 Then v = 1 'NoDuPremJourSem=1 pour lundi(ici=2) JX = Weekday(DateJ1, v) 'N°1'JourSem (1=dim 2=lundi) 'sans NoDuPremJourSem c'est vbMonday(valeur 2 Lundi) 'JX = Weekday(DateJ1, vbMonday) 'no 1'JourSem Lundi. '--------------------------------------------------- If JX = 1 Then JX = 8 'si = lundi sauter la 1'ligne dans CadreDesJours DateJ1 = DateJ1 - JX 'départ avant le 1'NoJour du mois(1'case jours mois précédent) ' init listes Annee - Mois (False pour éviter répétition événement) CbAnnee.Enabled = False: CbAnnee.Value = AnneSelect: CbAnnee.Enabled = True CbMois.Enabled = False: CbMois.ListIndex = MoisSelect - 1: CbMois.Enabled = True LbNoSem1 = "": LbNoSem2 = "": LbNoSem3 = "": LbNoSem4 = "": LbNoSem5 = "": LbNoSem6 = "" ' boucle sur les cases jours(CadreDesJours) LbFerie = "" For Each CaseJR In CadreJours.Controls DateJR = DateJ1 + Val(CaseJR.Tag) NoJour = Day(DateJR): CaseJR.Caption = NoJour NoSemISO = FCalendrierNoDeSemISO(DateJR) Select Case Val(CaseJR.Tag) Case 1 To 7: If LbNoSem1 = "" Then LbNoSem1 = NoSemISO Case 8 To 14: If LbNoSem2 = "" Then LbNoSem2 = NoSemISO Case 15 To 21: If LbNoSem3 = "" Then LbNoSem3 = NoSemISO Case 22 To 28: If LbNoSem4 = "" Then LbNoSem4 = NoSemISO Case 29 To 35: If LbNoSem5 = "" Then LbNoSem5 = NoSemISO Case 36 To 42: If LbNoSem6 = "" Then LbNoSem6 = NoSemISO End Select 'test accès possible aux cases jours Mois = Month(DateJR): Anne = Year(DateJR) CaseJR.SpecialEffect = fmSpecialEffectRaised JrVisible = True: JrEnabled = False If DateJR < ("01/01/" & CalPremANNEE) Or DateJR > ("31/12/" & CalDernANNEE) Then JrVisible = False ElseIf DateJR >= CalDateDEBUT And DateJR <= CalDateFIN Then Select Case ChoixAffJrsCal ' 1)que le mois 2)+suivant 3)+précédent Case 1: If Mois = MoisSelect Then JrVisible = True: JrEnabled = True Case 2: If (Mois >= MoisSelect And Anne = AnneSelect) Or (Mois < MoisSelect And Anne = AnneSelect + 1) Then JrVisible = True: JrEnabled = True Case Else: JrVisible = True: JrEnabled = True '3 ou tout autre valeur!? End Select 'tests avant avec AffTousLesJours True/False 'ce test pour afficher tous les jours ou le mois sélectionné seulement 'If AffTousLesJours Or Mois = MoisSelect Then JrVisible = True: JrEnabled = True 'ou test pour afficher tous les jours ou le mois sélectionné et le mois suivant(en bas) 'If AffTousLesJours Or ((Mois >= MoisSelect And Anne = AnneSelect) Or (Mois < MoisSelect And Anne = AnneSelect + 1)) Then JrVisible = True: JrEnabled = True End If CaseJR.Visible = JrVisible: CaseJR.Enabled = JrEnabled If DateJR = CalDateSELECT Then CaseJR.SpecialEffect = fmSpecialEffectSunken CaseJR.BackColor = &HC00000 ' &HFF0000 'fond bleu CaseJR.ForeColor = &HFFFFFF 'font blanc CaseJR.Font.Bold = True LbFerie = FCalendrierJourFerie(NoJour, MoisSelect) CaseJR.ControlTipText = LbFerie Else CaseJR.BackColor = &HE0E0E0 '+gris CaseJR.ForeColor = &H800000 'font bleu CaseJR.Font.Bold = False If Mois <> MoisSelect Then CaseJR.BackColor = &HFFFFFF 'blanc If CaseJR.Enabled = True Then If Mois = MoisSelect - 1 Then i = MoisSelect - 1 ElseIf Mois = MoisSelect Then i = MoisSelect ElseIf Mois = MoisSelect + 1 Then i = MoisSelect + 1 Else: i = 0 End If If i Then CaseJR.ControlTipText = FCalendrierJourFerie(NoJour, i): If CaseJR.ControlTipText > "" Then CaseJR.BackColor = &H8080FF: CaseJR.ControlTipText = FCalendrierJourFerie(NoJour, i) End If End If Next Set CaseJR = Nothing End Sub ' . ' Les Contrôles Dates . Private Sub LbAujourdhui_Click() CalendrierMiseAjour Date End Sub Private Sub CursMois_SpinUp() 'mois > Dim D As Date: D = "01/" & CbMois.ListIndex + 1 & "/" & CbAnnee.Value If D < CalDateFIN Then CbMois.Enabled = False: CbAnnee.Enabled = False If CbMois.ListIndex + 1 < 12 Then CbMois.ListIndex = CbMois.ListIndex + 1 ElseIf CbAnnee.Value < CalDernANNEE Then 'saute+1année CbMois.ListIndex = 0: CbAnnee.Value = CbAnnee.Value + 1 End If D = "01/" & CbMois.ListIndex + 1 & "/" & CbAnnee.Value CbMois.Enabled = True: CbAnnee.Enabled = True Else: D = CalDateFIN End If If D > CalDateFIN Then D = CalDateFIN CalendrierMiseAjour D End Sub Private Sub CursMois_SpinDown() 'mois < Dim D As Date: D = "01/" & CbMois.ListIndex + 1 & "/" & CbAnnee.Value If D > CalDateDEBUT Then CbMois.Enabled = False: CbAnnee.Enabled = False If CbMois.ListIndex + 1 > 1 Then CbMois.ListIndex = CbMois.ListIndex - 1 ElseIf CbAnnee.Value > CalPremANNEE Then 'saute-1année CbMois.ListIndex = 11: CbAnnee.Value = CbAnnee.Value - 1 End If D = "01/" & CbMois.ListIndex + 1 & "/" & CbAnnee.Value CbMois.Enabled = True: CbAnnee.Enabled = True Else: D = CalDateDEBUT End If If D < CalDateDEBUT Then D = CalDateDEBUT CalendrierMiseAjour D End Sub Private Sub CbMois_Change() 'Mois (pour combobox car avec curseurs inutile) If CbMois.Enabled = False Then Exit Sub J = 1: m = CbMois.ListIndex + 1: If m > 12 Then m = 12 If (J & "/" & m & "/" & CbAnnee.Value) <= CalDateDEBUT Then J = Day(CalDateDEBUT): m = Month(CalDateDEBUT) ElseIf (J & "/" & m & "/" & CbAnnee.Value) >= CalDateFIN Then J = Day(CalDateFIN): m = Month(CalDateFIN) End If CalendrierMiseAjour J & "/" & m & "/" & CbAnnee.Value End Sub Private Sub CursAnnee_SpinUp() 'année > If CbAnnee.Value < CalDernANNEE Then J = 1: m = CbMois.ListIndex + 1: If m > 12 Then m = 12 CbAnnee.Enabled = False: CbAnnee.Value = CbAnnee.Value + 1: CbAnnee.Enabled = True If (J & "/" & m & "/" & CbAnnee.Value) > CalDateFIN Then J = Day(CalDateFIN): m = Month(CalDateFIN) CalendrierMiseAjour J & "/" & m & "/" & CbAnnee.Value End If End Sub Private Sub CursAnnee_SpinDown() 'année < If CbAnnee.Value > CalPremANNEE Then J = 1: m = CbMois.ListIndex + 1: If m > 12 Then m = 12 CbAnnee.Enabled = False: CbAnnee.Value = CbAnnee.Value - 1: CbAnnee.Enabled = True If (J & "/" & m & "/" & CbAnnee.Value) < CalDateDEBUT Then J = Day(CalDateDEBUT): m = Month(CalDateDEBUT) CalendrierMiseAjour J & "/" & m & "/" & CbAnnee.Value End If End Sub Private Sub CbAnnee_Change() 'Annee (pour combobox car avec curseurs inutile) If CbAnnee.Enabled = False Then Exit Sub J = 1: m = CbMois.ListIndex + 1: If m > 12 Then m = 12 If (J & "/" & m & "/" & CbAnnee.Value) <= CalDateDEBUT Then J = Day(CalDateDEBUT): m = Month(CalDateDEBUT) ElseIf (J & "/" & m & "/" & CbAnnee.Value) >= CalDateFIN Then J = Day(CalDateFIN): m = Month(CalDateFIN) End If CalendrierMiseAjour J & "/" & m & "/" & CbAnnee.Value End Sub 'norme ISO(Sem 4 Jrs mini)(de Renauder XLD)(rajout le choix du 1'jour sem Private Function FCalendrierNoDeSemISO(D As Date) Dim T&, v%: v = NoDuPremJourSem - 1: If v < 1 Then v = 7 '(1=dim 2=lundi...) T = DateSerial(Year(D + (8 - Weekday(D - v)) Mod 7 - 3), 1, 1) FCalendrierNoDeSemISO = ((D - T - 3 + (Weekday(T - v) + 1) Mod 7)) \ 7 + 1 End Function 'sans 1'jour c'est ceci départ Lundi. mais ne change rien. NoDuPremJourSem=1 pour lundi et ici+1 car Lundi=2 'Private Function FCalendrierNoDeSemISO(D As Date) 'norme ISO(Sem 4 Jrs mini)(de Renauder XLD) 'Dim T&: T = DateSerial(Year(D + (8 - Weekday(D)) Mod 7 - 3), 1, 1) 'FCalendrierNoDeSemISO = ((D - T - 3 + (Weekday(T) + 1) Mod 7)) \ 7 + 1 'End Function ' Routines Feries . ' . '###### CECI EST MODIFIABLE ! VOIR UN PEU PLUS BAS ### CHOIX DU PAYS ### ' . Private Function FCalendrierJourFerie(JF%, MF%) 'Jours Fériés ce jour/mois/CbAnnee.Value Dim DatePaque As Date, DateAscension As Date, DatePentecote As Date, DateCours As Date, DateX As Date Dim Jpaq%, Mpaq%, JLpaq%, MLpaq%, Jasc%, Masc%, Jpent%, Mpent%, JLpent%, MLpent% Dim Annee%, a%, B%, C%, D%, E%, F%, T$ Annee = CbAnnee.Value 'année '- fêtes religieuses (fonction oudin) a = Annee Mod 19: B = Annee \ 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 = (Annee + Annee \ 4 + D + 2 - B + B \ 4) Mod 7: F = D - E Mpaq = 3 + (F + 40) \ 44: Jpaq = F + 28 - 31 * (Mpaq \ 4) '- DatePaque /DateAscension /DatePentecote DatePaque = DateSerial(Annee, Mpaq, Jpaq) DateAscension = DatePaque + 39: DatePentecote = DatePaque + 49 Jasc = Day(DateAscension): Masc = Month(DateAscension) Jpent = Day(DatePentecote): Mpent = Month(DatePentecote) JLpaq = Day(DatePaque + 1): MLpaq = Month(DatePaque + 1) JLpent = Day(DatePentecote + 1): MLpent = Month(DatePentecote + 1) '- tableau jours fériés (2 fériés peuvent tomber le même jour)---- ReDim Fer$(0) DateCours = JF & "/" & MF & "/" & Annee If AnneeNVM > 0 Then GoTo FerieNVM '#NVM# Util_Roland 'mettre en rem les goto inutiles ### CHOIX DU PAYS ### GoTo FerieFrce 'GoTo FerieQuebec ' '... si tous les goto en rem ICI VOS JOURS FERIES MODIFIES . 'civiles fixes Select Case Trim(JF) & "," & Trim(MF) Case "1,1": AjoutFerieTablo Fer$(), "Nouvel AN" Case "25,12": AjoutFerieTablo Fer$(), "Nôel" End Select ' religieux à voir !? si pas mettre en rem If Jpaq = JF And Mpaq = MF Then AjoutFerieTablo Fer$(), "Pâques" If JLpaq = JF And MLpaq = MF Then AjoutFerieTablo Fer$(), "Lund.Pâques" If Jasc = JF And Masc = MF Then AjoutFerieTablo Fer$(), "Ascension" If Jpent = JF And Mpent = MF Then AjoutFerieTablo Fer$(), "Pentecôte" If JLpent = JF And MLpent = MF Then AjoutFerieTablo Fer$(), "Lund.Pentecôte" GoTo SuiteCal '< suite . FerieFrce: ' FRANCE ' civiles fixes Select Case Trim(JF) & "," & Trim(MF) Case "1,1": AjoutFerieTablo Fer$(), "Nouvel AN" Case "1,5": AjoutFerieTablo Fer$(), "Fête du Travail" Case "8,5": AjoutFerieTablo Fer$(), "Victoire 1945" Case "14,7": AjoutFerieTablo Fer$(), "Fête Nationale" Case "15,8": AjoutFerieTablo Fer$(), "Assomption" Case "1,11": AjoutFerieTablo Fer$(), "Toussaint" Case "11,11": AjoutFerieTablo Fer$(), "Armistice 1918" Case "25,12": AjoutFerieTablo Fer$(), "Nôel" End Select ' religieux If Jpaq = JF And Mpaq = MF Then AjoutFerieTablo Fer$(), "Pâques" If JLpaq = JF And MLpaq = MF Then AjoutFerieTablo Fer$(), "Lund.Pâques" If Jasc = JF And Masc = MF Then AjoutFerieTablo Fer$(), "Ascension" If Jpent = JF And Mpent = MF Then AjoutFerieTablo Fer$(), "Pentecôte" If JLpent = JF And MLpent = MF Then AjoutFerieTablo Fer$(), "Lund.Pentecôte" GoTo SuiteCal ' . FerieNVM: ' BELGIQUE ' civiles fixes Select Case Trim(JF) & "," & Trim(MF) Case "1,1": AjoutFerieTablo Fer$(), "Nouvel AN" Case "1,5": AjoutFerieTablo Fer$(), "Fête du Travail" Case "21,7": AjoutFerieTablo Fer$(), "Fête Nationale" Case "15,8": AjoutFerieTablo Fer$(), "Assomption" Case "1,11": AjoutFerieTablo Fer$(), "Toussaint" Case "11,11": AjoutFerieTablo Fer$(), "Armistice 1918" Case "25,12": AjoutFerieTablo Fer$(), "Nôel" End Select ' religieux If Jpaq = JF And Mpaq = MF Then AjoutFerieTablo Fer$(), "Pâques" If JLpaq = JF And MLpaq = MF Then AjoutFerieTablo Fer$(), "Lund.Pâques" If Jasc = JF And Masc = MF Then AjoutFerieTablo Fer$(), "Ascension" If Jpent = JF And Mpent = MF Then AjoutFerieTablo Fer$(), "Pentecôte" If JLpent = JF And MLpent = MF Then AjoutFerieTablo Fer$(), "Lund.Pentecôte" GoTo SuiteCal ' . FerieQuebec: ' QUEBEC ' civiles fixes Select Case Trim(JF) & "," & Trim(MF) Case "1,1": AjoutFerieTablo Fer$(), "Nouvel AN" Case "24,6": AjoutFerieTablo Fer$(), "Fête Nationale du Québec" Case "25,12": AjoutFerieTablo Fer$(), "Nôel" End Select ' religieux If Jpaq = JF And Mpaq = MF Then AjoutFerieTablo Fer$(), "Pâque" If JLpaq = JF And MLpaq = MF Then AjoutFerieTablo Fer$(), "Lund.Pâque" If Jasc = JF And Masc = MF Then AjoutFerieTablo Fer$(), "Ascension" If Jpent = JF And Mpent = MF Then AjoutFerieTablo Fer$(), "Pentecôte" If JLpent = JF And MLpent = MF Then AjoutFerieTablo Fer$(), "Lund.Pentecôte" '--- vend.saint l'avant veille de pâque If DateCours = DatePaque - 2 Then AjoutFerieTablo Fer$(), "Vendredi Saint" '--- le lundi qui précède le 25 mai =(Journée nationale des patriotes) DateX = "25/05/" & Annee: DateX = DateX - Weekday(DateX, vbMonday) + 1 If DateCours = DateX Then AjoutFerieTablo Fer$(), "Journée Nationale des Patriotes" '--- le 1er juillet. Si cette date tombe un dimanche : le 2 juillet (Fête du Canada) DateX = "01/07/" & Annee If DateCours = DateX And Weekday(DateX, vbMonday) <> 7 Then AjoutFerieTablo Fer$(), "Fête du Canada" ElseIf DateCours = DateX + 1 And Weekday(DateX, vbMonday) <> 7 Then If DateCours - 1 = DateX And Weekday(DateX, vbMonday) = 7 Then AjoutFerieTablo Fer$(), "Fête du Canada" End If '--- le 1er lundi de septembre (fête du Travail) DateX = "01/09/" & Annee: DateX = DateX + 7 - Weekday(DateX - 1, vbMonday) If DateCours = DateX Then AjoutFerieTablo Fer$(), "Fête du Travail" '--- le 2e lundi d’octobre (Action de grâces) DateX = "01/10/" & Annee: DateX = DateX + 14 - Weekday(DateX - 1, vbMonday) If DateCours = DateX Then AjoutFerieTablo Fer$(), "Action de Grâces" GoTo SuiteCal ' . SuiteCal: T$ = "" For a = 1 To UBound(Fer$()) If Fer$(a) > "" Then T$ = T$ & Fer$(a) & "\" Next If T$ > "" Then If Right(T$, 1) = "\" Then T$ = Left(T$, Len(T$) - 1) FCalendrierJourFerie = T$ End Function Private Sub AjoutFerieTablo(Fer$(), n$) 'appel ci-dessus ReDim Preserve Fer$(UBound(Fer$()) + 1): Fer$(UBound(Fer$())) = n$ End Sub Private Sub LbFerie_Click(): AffFeries: End Sub Private Sub LbFeries_Click(): AffFeries: End Sub Private Sub AffFeries() 'aff.liste fériés Dim X$, dat As Date, TotJ%, NbrJ% For m = 1 To 12 TotJ = Choose(m, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) If m = 2 Then If CbAnnee Mod 4 = 0 And (CbAnnee Mod 100 <> 0 Or CbAnnee Mod 400 = 0) Then TotJ = TotJ + 1 For J = 1 To TotJ If FCalendrierJourFerie(J, m) > "" Then NbrJ = NbrJ + 1: dat = J & "/" & m & "/" & CbAnnee: X$ = X$ & Format(dat, FormatDateUser$) & " " & FCalendrierJourFerie(J, m) & vbLf Next: Next MsgBox X$, , NbrJ & " jours" End Sub '-------------------------------------------------------------------------------- ' ROUTINES D'APPEL DU CALENDRIER . '-------------------------------------------------------------------------------- Public Function FFormatDateUser$(): FFormatDateUser$ = FormatDateUser$: Unload Me: End Function ' ROUTINE D'APPEL DEPUIS UN MODULE ou autre pour saisir une variable Date . '-------------------------------------------------------------------------------- Public Sub SelectDateDIVERS(DateSelect As Variant, Optional FormatDate$) If Not IsDate(DateSelect) Then DateSelect = Date DateSelectUser = DateSelect: PositionUserf$ = "centre": Me.Show 'après Hide et Exit Sub suite ci-dessous If IsDate(DateSelectUser) Then DateSelect = CDate(DateSelectUser): FormatDate$ = FormatDateUser$ Unload Me 'décharge calendrier End Sub ' ROUTINE D'APPEL SUR CELLULE ACTIVE . '------------------------------------------------ Public Sub SelectDateCELL1(DateSelect As Variant) If Not IsDate(DateSelect) Then DateSelect = Date DateSelectUser = DateSelect: PositionUserf$ = "cell": Me.Show 'après Hide et Exit Sub suite ci-dessous If IsDate(DateSelectUser) Then ActiveCell = CDate(DateSelectUser) If FormatDateUserSurCell Then ActiveCell.NumberFormat = FormatDateUser$ End If Unload Me 'décharge calendrier End Sub ' ROUTINE D'APPEL SUR CELLULE ACTIVE AVEC MIN/MAX . '----------------------------------------------------------- Public Sub SelectDateCELL2(CellDatMin As Variant, CellDatMax As Variant) If Not IsDate(CellDatMin) Then CellDatMin = Date If Not IsDate(CellDatMax) Then CellDatMax = Date CalDateDEBUT = CellDatMin: CalDateFIN = CellDatMax 'effectuer les tests limites ici! If CalDateDEBUT > CalDateFIN Then MsgBox "Vos dates d'appel sont incohérentes !?" & vbLf & "revoir les limites mini/maxi !", vbCritical, "err date" Else DateSelectUser = "DatMinMax": PositionUserf$ = "cell": Me.Show 'après Hide et Exit Sub suite ci-dessous If IsDate(DateSelectUser) Then ActiveCell = CDate(DateSelectUser) If FormatDateUserSurCell Then ActiveCell.NumberFormat = FormatDateUser$ End If End If Unload Me 'décharge calendrier End Sub ' ROUTINE D'APPEL SUR UN SEUL CONTROLE . '------------------------------------------------- Public Sub SelectDateCTRL1(fmMe As Object, CtrlDat As Control, Optional AnNVM%) Dim SvgCtrlDat As Variant, DatCal As Date SvgCtrlDat = CtrlDat: AnneeNVM = AnNVM '#NVM# Util_Roland If IsDate(CtrlDat) Then DatCal = CtrlDat Else DatCal = Date: CtrlDat = DatCal 'init DatCal 'init PosUserfAppelTop/Left pour ensuite positionner cal sur l'objet appelant If AnneeNVM > 0 Then '#NVM# Util_Roland 'coordonnées sur la croix PosUserfAppelTop = fmMe.Top: If PosUserfAppelTop <= 0 Then PosUserfAppelTop = 1 PosUserfAppelLeft = fmMe.Left + fmMe.Width - Me.Width: If PosUserfAppelLeft <= 0 Then PosUserfAppelLeft = 1 Else 'sur l'objet appelant UserformInitPosObjAppelant fmMe, CtrlDat, PosUserfAppelLeft, PosUserfAppelTop 'avec un seul frame 'If CtrlDat.Parent.Name <> fmMe.Name Then 'test si dans frame ' PosUserfAppelTop = PosUserfAppelTop + CtrlDat.Parent.Top ' PosUserfAppelLeft = PosUserfAppelLeft + CtrlDat.Parent.Left 'End If 'centre userf appelant 'PosUserfAppelTop = fmMe.Top + fmMe.Height * 0.5 - Me.Height * 0.5 'PosUserfAppelLeft = fmMe.Left + fmMe.Width * 0.5 - Me.Width * 0.5 End If Me.Caption = "" 'msg caption DateSelectUser = DatCal: PositionUserf$ = "ctrl": Me.Show 'après Hide et Exit Sub suite ci-dessous 'récupère la date If IsDate(DateSelectUser) Then DatCal = CDate(DateSelectUser) CtrlDat = Format(DatCal, FormatDateUser$) Else 'reinit CtrlDat = SvgCtrlDat End If ' Unload Me 'décharge calendrier End Sub ' ROUTINE D'APPEL SUR DEUX CONTROLES DEBUT/FIN Choix$= "deb" ou "fin" . '-------------------------------------------------------------------------------- Public Sub SelectDateCTRL2(fmMe As Object, CtrlDeb As Control, CtrlFin As Control, Choix$, Optional AnNVM%) Dim SvgCtrlDeb As Variant, SvgCtrlFin As Variant, DatCal As Date, MsgCaption$, dd$, DF$, xChoix$ Dim CtrlAppelant As Control 'Deb ou Fin dd$ = "deb": DF$ = "fin": xChoix$ = LCase(Choix$): AnneeNVM = AnNVM '#NVM# Util_Roland SvgCtrlDeb = CtrlDeb: SvgCtrlFin = CtrlFin If Not IsDate(CtrlDeb) Then CtrlDeb = Date If Not IsDate(CtrlFin) Then CtrlFin = Date If CDate(CtrlDeb) > CDate(CtrlFin) Then CtrlDeb = CtrlFin If xChoix$ = dd$ Then Set CtrlAppelant = CtrlDeb DatCal = CDate(CtrlDeb): MsgCaption$ = "Date début ?" & " /fin=" & CDate(CtrlFin) End If If xChoix$ = DF$ Then Set CtrlAppelant = CtrlFin DatCal = CDate(CtrlFin): MsgCaption$ = "Date fin ?" & " /début=" & CDate(CtrlDeb) End If 'init PosUserfAppelTop/Left pour ensuite positionner cal sur l'objet appelant If AnneeNVM > 0 Then '#NVM# Util_Roland 'coordonnées sur la croix PosUserfAppelTop = fmMe.Top: If PosUserfAppelTop <= 0 Then PosUserfAppelTop = 1 PosUserfAppelLeft = fmMe.Left + fmMe.Width - Me.Width: If PosUserfAppelLeft <= 0 Then PosUserfAppelLeft = 1 Else 'sur l'objet appelant UserformInitPosObjAppelant fmMe, CtrlAppelant, PosUserfAppelLeft, PosUserfAppelTop 'avec un seul frame 'If CtrlAppelant.Parent.Name <> fmMe.Name Then 'test si dans frame ' PosUserfAppelTop = PosUserfAppelTop + CtrlAppelant.Parent.Top ' PosUserfAppelLeft = PosUserfAppelLeft + CtrlAppelant.Parent.Left 'End If 'centre userf appelant 'PosUserfAppelTop = fmMe.Top + fmMe.Height * 0.5 - Me.Height * 0.5 'PosUserfAppelLeft = fmMe.Left + fmMe.Width * 0.5 - Me.Width * 0.5 End If Me.Caption = MsgCaption$ 'msg caption DateSelectUser = DatCal: PositionUserf$ = "ctrl": Me.Show 'après Hide et Exit Sub suite ci-dessous 'récupère la date If IsDate(DateSelectUser) Then DatCal = CDate(DateSelectUser) If xChoix$ = dd$ Then CtrlDeb = Format(DatCal, FormatDateUser$) If DatCal > CDate(CtrlFin) Then CtrlFin = Format(DatCal, FormatDateUser$) ElseIf xChoix$ = DF$ Then If DatCal >= CDate(CtrlDeb) Then CtrlFin = Format(DatCal, FormatDateUser$) Else: CtrlDeb = Format(DatCal, FormatDateUser$) End If Else 'reinit If Not CtrlDeb Is Nothing Then CtrlDeb = SvgCtrlDeb If Not CtrlFin Is Nothing Then CtrlFin = SvgCtrlFin End If ' Unload Me 'décharge calendrier End Sub '------------------------------------------------------------------- ' Position du calendrier sur objet appelant . 'appel UserformZoomResolution UserformPosition !? . '------------------------------------------------------------------- Private Sub CalendrierPosition() UserformZoomResolution Me, 1440 '<1440 résolutionX à la création If PositionUserf$ = "ctrl" Then 'Pos/Userf UserformPosSurXY Me, PosUserfAppelLeft, PosUserfAppelTop ElseIf PositionUserf$ = "cell" Then 'Pos/Cell UserformPosSurCell Me, ActiveCell Else 'Pos/CentreUserf Appelant UserformPosSurXY Me, 0, 0, "CentreUserf" End If End Sub 'ceci empêche le déplacement de l'userf cal hors écran soit avec Me '------------------------------------------------------------------ Private Sub UserForm_Layout() Dim ScrWpt%, ScrHpt%, HautBarPt% HautBarPt = 30 - (10 And Int(Val(Application.Version)) < 12) ScrWpt = Application.Width - 12: ScrHpt = Application.Height + 18 If Me.Left < 0 Then Me.Left = 0 If Me.Top < 0 Then Me.Top = 0 If Me.Left + Me.Width > ScrWpt Then Me.Left = ScrWpt - Me.Width If Me.Top + Me.Height + HautBarPt > ScrHpt Then Me.Top = ScrHpt - Me.Height - HautBarPt End Sub ' ROUTINE STD INIT POSITION X/Y OBJET SUR USERFORM '------------------------------------------------------- Public Sub UserformInitPosObjAppelant(fmMe As Object, obj As Object, X@, Y@) 'X/Y en retour Y = fmMe.Top + obj.Top + 24 ' fmMe.Name Y = Y + CtrlX.Parent.Top + 4 X = X + CtrlX.Parent.Left + 2 Set CtrlX = CtrlX.Parent Wend On Error GoTo 0: Err.Clear Set CtrlX = Nothing End Sub ' ROUTINE STD POSITION USERFORM SUR X/Y ou CentreUserf(appelant) '--------------------------------------------------------------------- Public Sub UserformPosSurXY(fmMe As Object, XX As Variant, YY As Variant, Optional Pos$) Dim ScrWpt%, ScrHpt%, HautBarPt%, X As Variant, Y As Variant HautBarPt = 30 - (10 And Int(Val(Application.Version)) < 12) ScrWpt = Application.Width - 12: ScrHpt = Application.Height + 18 X = XX: Y = YY If Pos$ = "CentreUserf" Then X = (ScrWpt - fmMe.Width) * 0.5: Y = (ScrHpt - fmMe.Height) * 0.5 If X < 1 Then X = 1 If X + fmMe.Width > ScrWpt Then X = ScrWpt - fmMe.Width If Y < 1 Then Y = 1 If Y + fmMe.Height + HautBarPt > ScrHpt Then Y = ScrHpt - fmMe.Height - HautBarPt With fmMe: .StartUpPosition = 0: .Top = Y: .Left = X: End With End Sub ' ROUTINE STD POSITION USERFORM SUR CELLULE . '--------------------------------------------------- Public Sub UserformPosSurCell(fmMe As Object, Rng As Range) Dim SvgScr As Boolean 'les fonctions PointsToScreenPixelsX/Y nécessitent que ScreenUpdating=True SvgScr = Application.ScreenUpdating: Application.ScreenUpdating = True 'init FPtToPx extrait de Function FPtToPx#() Dim FPtToPx# On Error Resume Next: Err.Clear FPtToPx = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72 If Err Then If Int(Val(Application.Version)) >= 12 Then '2007 et + FPtToPx = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(ActiveSheet.[A1].Width) - ActiveWindow.ActivePane.PointsToScreenPixelsX(0)) / ActiveSheet.[A1].Width) / (ActiveWindow.Zoom / 100) Else FPtToPx = 96 / 72 'inf 2007 (1.333..)(96 mis en dur si problème modifier cette valeur) End If End If On Error GoTo 0: Err.Clear 'init ces vars pour le calcul de TotLigOffset si volets figés !?! 'si volet&cell.select en haut, calc lignes scrollées partie basse Dim NoLigScroll&, NoColScroll&, TotLigScroll&, TotColScroll&, Zoum@ Zoum = ActiveWindow.Zoom / 100 NoLigScroll = ActiveWindow.ScrollRow: NoColScroll = ActiveWindow.ScrollColumn TotLigScroll = ActiveWindow.SplitRow: TotColScroll = ActiveWindow.SplitColumn Dim TotLigOffset&, NoPremLigZone2&, NoDernLigZone1& If ActiveWindow.FreezePanes = True Then If TotLigScroll > 0 And Rng.Row < NoLigScroll Then NoPremLigZone2 = ActiveWindow.ScrollRow NoDernLigZone1 = ActiveWindow.Panes(1).ScrollRow + ActiveWindow.SplitRow - 1 If NoPremLigZone2 - 1 > NoDernLigZone1 Then TotLigOffset = NoPremLigZone2 - NoDernLigZone1 - 1 End If End If 'init ces vars pour position finale Dim Cel As Range, PosTop@, PosLeft@ Set Cel = Rng.Offset(TotLigOffset, 0) If Int(Val(Application.Version)) >= 12 Then '2007 et + pour ActivePane PosTop = ActiveWindow.ActivePane.PointsToScreenPixelsY(Cel.Top) / FPtToPx PosLeft = ActiveWindow.ActivePane.PointsToScreenPixelsX(Cel.Left) / FPtToPx Else PosTop = ActiveWindow.PointsToScreenPixelsY(Cel.Top * FPtToPx) / FPtToPx 'inf 2007 PosLeft = ActiveWindow.PointsToScreenPixelsX(Cel.Left * FPtToPx) / FPtToPx 'inf 2007 End If 'positionne Dim ScrWpt%, ScrHpt%, PosTopMaxi@, PosLeftMaxi@ ScrWpt = Application.Width - 12: ScrHpt = Application.Height + 18 PosTop = PosTop + 1: PosLeft = PosLeft + 1 PosTopMaxi = ScrHpt - fmMe.Height PosLeftMaxi = ScrWpt - fmMe.Width If PosTop > PosTopMaxi Then PosTop = PosTopMaxi If PosLeft > PosLeftMaxi Then PosLeft = PosLeftMaxi With fmMe: .Top = PosTop: .Left = PosLeft: End With Application.ScreenUpdating = SvgScr End Sub ' ROUTINE STD ZOOM USERFORM . '------------------------------------------------- Public Sub UserformZoomResolution(fmMe As Object, RxDeBase@) ' RxDeBase Then If RxActuel > RxDeBase Then RX = RxActuel / RxDeBase: RX = 1 + ((RX - 1) * 0.2) Else RX = RxDeBase / RxActuel: RX = 1 - ((RX - 1) * 0.2) End If If RX > 4 Then RX = 4 'zoom maxi 400 With fmMe '8et24 =haut&bords userf .Zoom = 100 * RX .Width = (.Width - 8) * RX + 8 .Height = (.Height - 24) * RX + 24 End With End If End Sub