En gras personnellement je ne vois pas la différence, mais tu peux faire ceci :
Sub affichercalendrier(Optional quand As Date = -1)
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 = RGB(192, 192, 240)
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, "_J", "J", RGB(240, 0, 240), RGB(240, 240, 240), "'affichercalendrier(" & CLng(Date) & ")'", False
dessiner posx + 6 + 1 + 28, posy + 6, 28 - 2, 16, "_Moins", "<<", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moismoins & ")'", False
dessiner posx + 6 + 1 + 28 * 2, posy + 6, 28 * 3 - 2, 16, "_Mois", Format(DateSerial(annee, mois, 1), "mmm-yyyy"), RGB(240, 0, 240), RGB(240, 240, 240), "'MsgBox ""Mike Steelson""'", True
dessiner posx + 6 + 1 + 28 * 5, posy + 6, 28 - 2, 16, "_Plus", ">>", RGB(0, 0, 0), RGB(192, 192, 192), "'affichercalendrier(" & moisplus & ")'", False
dessiner posx + 6 + 1 + 28 * 6, posy + 6, 28 - 2, 16, "_X", "X", RGB(240, 0, 0), RGB(240, 240, 240), "'fermercalendrier'", False
For j = 1 To 7
dessiner posx + 6 + 28 * (j - 1), posy + 10 + 16, 28, 16, "_J" & j, Format(j + 1, "ddd") & j, RGB(128, 128, 128), RGB(192, 192, 240), "", 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(EstJourFerie(jour), RGB(240, 0, 0), IIf(jour = Date, RGB(240, 240, 240), IIf(Weekday(jour, vbMonday) > 5, RGB(0, 0, 240), RGB(0, 0, 0)))), _
IIf(jour = Date, RGB(0, 0, 240), IIf(Month(jour) = mois, RGB(240, 240, 240), RGB(192, 192, 192))), _
"'ChoixDate(" & jour & ")'", _
IIf(jour = Date, True, False)
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
et
Sub dessiner(x%, y%, l%, h%, nom$, texte$, police As Long, fond As Long, action$, gras As Boolean, 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
.TextFrame.Characters.Font.Bold = gras
End With
End Sub