A noter que la partie importée qui déterminait les jours fériés comportait une erreur. J'ai donc opté pour un autre code que cette fois-ci j'ai entièrement vérifié.
Option Explicit
Const prefixe = "MSCalend"
Dim MSjour As Range
' mike steelson
Sub affichercalendrier(Optional quand As Date = -1)
' couleurs
Dim fondJour, fond, police, policeSemaine, policeWE, policeFerie, fondAujourdhui, policeFermeture, fondAutreMois
' paramètres couleur =============
fond = RGB(168, 192, 240)
fondJour = RGB(240, 240, 240)
fondAujourdhui = RGB(240, 240, 0)
fondAutreMois = RGB(192, 192, 192)
police = RGB(0, 0, 0)
policeSemaine = RGB(128, 128, 128)
policeWE = RGB(0, 0, 240)
policeFerie = RGB(240, 0, 0)
policeFermeture = RGB(240, 0, 0)
' ================================
Dim Sh As Object, posx%, posy%, i%, j%, tableau() As String
Dim jour As Long, mois As Integer, annee As Integer, moisplus As Long, moismoins As Long
If MSjour Is Nothing Then Set MSjour = Selection
For Each Sh In ActiveSheet.Shapes
If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
Next
posx = MSjour.Offset(0, 1).Left + 2: posy = MSjour.Top + 2
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
posx, posy, 208, 144)
.Name = prefixe
.Visible = True
.Fill.ForeColor.RGB = fond
End With
If quand = -1 Then quand = IIf(MSjour = "", Date, MSjour)
quand = DateSerial(Year(quand), Month(quand), 1)
quand = quand - Weekday(quand, vbMonday) + 1
mois = Month(quand + 7)
annee = Year(quand + 7)
moismoins = DateSerial(annee, mois - 1, 1)
moisplus = DateSerial(annee, mois + 1, 1)
dessiner posx + 6 + 1, posy + 6, 28 - 2, 16, "_M", "M", police, fondAujourdhui, "'affichercalendrier(" & CLng(Date) & ")'"
dessiner posx + 6 + 1 + 28, posy + 6, 28 - 2, 16, "_Moins", "<<", police, fondAutreMois, "'affichercalendrier(" & moismoins & ")'"
dessiner posx + 6 + 1 + 28 * 2, posy + 6, 28 * 3 - 2, 16, "_Mois", Format(DateSerial(annee, mois, 1), "mmm-yyyy"), police, fondJour, "'MsgBox ""Mike Steelson""'"
dessiner posx + 6 + 1 + 28 * 5, posy + 6, 28 - 2, 16, "_Plus", ">>", police, fondAutreMois, "'affichercalendrier(" & moisplus & ")'"
dessiner posx + 6 + 1 + 28 * 6, posy + 6, 28 - 2, 16, "_X", "X", policeFermeture, fondJour, "'fermercalendrier'"
For j = 1 To 7
dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16, 28, 16, "_J" & j, Format(j + 1, "ddd") & j, policeSemaine, fond, "", False
For i = 1 To 6
jour = quand + j + 7 * i - 8
dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16 * (i + 1), 28, 16, _
CStr(jour), _
Day(jour), _
IIf(IsFerie(jour), policeFerie, IIf(Weekday(jour, vbMonday) > 5, policeWE, police)), _
IIf(Month(jour) <> mois, fondAutreMois, IIf(jour = Date, fondAujourdhui, fondJour)), _
"'ChoixDate(" & jour & ")'"
Next
Next
For Each Sh In ActiveSheet.Shapes
If Left(Sh.Name, Len(prefixe)) = prefixe Then
i = i + 1
ReDim Preserve tableau(1 To i)
tableau(i) = Sh.Name
End If
Next
If i = 0 Then Exit Sub
Set Sh = ActiveSheet.Shapes.Range(tableau).Group
Sh.Name = prefixe & "_Groupe"
End Sub
Sub dessiner(x%, y%, l%, h%, nom$, texte$, ByVal police As Long, ByVal fond As Long, action$, Optional ligne = True)
With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, x, y, l, h)
.Name = prefixe & nom
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Text = texte
.TextFrame.Characters.Font.Size = 9
.Fill.ForeColor.RGB = fond
.TextFrame.Characters.Font.Color = police
.OnAction = action
.Line.Visible = ligne
End With
End Sub
Sub ChoixDate(quand)
On Error Resume Next ' cas où le calendrier est resté actif à la fermeture
Dim Sh As Object
MSjour.Value = quand
Set MSjour = Nothing
For Each Sh In ActiveSheet.Shapes
If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
Next
End Sub
Sub fermercalendrier()
Dim Sh As Object
Set MSjour = Nothing
For Each Sh In ActiveSheet.Shapes
If Left(Sh.Name, Len(prefixe)) = prefixe Then Sh.Delete
Next
End Sub
'===========partie importée=======================
' https://www.3stone.be/access5/articles.php?lng=fr&pg=106&tconfig=0
Function IsFerie(jour As Variant) As Boolean
'd'après Ole P Erlandsen
Dim ListeFeries(1 To 11) As Long, i As Integer
Dim tDate As Long, annee As Integer
IsFerie = False
tDate = CDate(jour)
If tDate < 1 Then Exit Function
annee = Year(tDate)
If annee < 1900 Then Exit Function
'remplit la liste des fériés
ListeFeries(1) = CDate("1/1/" & annee) 'Jour de l'An
ListeFeries(2) = fnPaques(annee) + 1 'Lundi de Pâques
ListeFeries(3) = ListeFeries(2) + 38 'Jeudi Ascension
ListeFeries(4) = ListeFeries(2) + 49 'Lundi Pentecôte
ListeFeries(5) = CDate("1/5/" & annee) '1er Mai
ListeFeries(6) = CDate("8/5/" & annee) '8 Mai
ListeFeries(7) = CDate("14/7/" & annee) '14 Juillet
ListeFeries(8) = CDate("15/8/" & annee) '15 Août
ListeFeries(9) = CDate("1/11/" & annee) 'Toussaint
ListeFeries(10) = CDate("11/11/" & annee) '14-18
ListeFeries(11) = CDate("25/12/" & annee) 'Noël
' compare la date entrée avec la Liste des Fériés
i = 1
While i <= UBound(ListeFeries) And IsFerie = False
If tDate = ListeFeries(i) Then IsFerie = True
i = i + 1
Wend
' ajout pour inclure Pâques dans les jours fériés
If tDate = fnPaques(Year(tDate)) Then IsFerie = True
End Function
Public Function fnPaques(wAn%) As Date
'Pâques est le dimanche qui suit le quatorzième jour de la
'Lune qui tombe le 21 mars ou immédiatement après
Dim wA%, wb%, wC%, wD%, wE%, wF%, wG%, wH%
Dim wI%, wJ%, wK%, wL%, wM%, wN%, wP%
wA = wAn Mod 19 'Calcul du rang de l'année dans le cycle lunaire qui a 19 ans
wb = wAn \ 100 'Calcul du siècle
wC = wAn Mod 100 'Calcul du rang de l'année dans le siècle
wD = wb \ 4
wE = wb Mod 4
wF = (wb + 8) \ 25
wG = (wb - wF + 1) \ 3
wH = (19 * wA + wb - wD - wG + 15) Mod 30
wI = wC \ 4
wK = wC Mod 4
wL = (32 + 2 * wE + 2 * wI - wH - wK) Mod 7
wM = (wA + 11 * wH + 22 * wL) \ 451
wN = (wH + wL - 7 * wM + 114) \ 31 'détermine le mois
wP = (wH + wL - 7 * wM + 114) Mod 31 'détermine le jour
fnPaques = DateSerial(wAn, wN, wP + 1)
End Function