Calendrier "mike steelson"

Question

J'utilise le calendrier de "mike steelson" et j'aurais une question, est-il possible de modifier la position à l'ouverture de ce calendrier, pas clair alors une image sera peut-être plus parlante!! A l'ouverture, lorsque je double-clique sur une cellule, là c'est la cellule vide en deuxième ligne, le calendrier se mets sur la droite de la cellule et la plupart du temps, suivante la date, je dois le déplacer "manuellement" pour l'utiliser et le fermer. La possibilité qu'il s'ouvre sous la cellule cliquée est elle possible?? je vous remercie Bonne journée...

saboh12617 · Accepted Answer

Du code vraiment très bien fait. Je comprends que ce M. Steelson était apprécié. Il suffit de modifier la ligne des posx et posy (posx = horizontal &#91;positif de gauche vers la droite&#93; , posy = vertical &#91;positif de haut en bas&#93;). Par exemple on peut se décaler de 2 cases à gauche (offset(0,-2)) et 1 case en bas(offset(1)), comme ceci : posx = MSjour.Offset(0, -2).Left + 2: posy = MSjour.Offset(1, 0).Top + 2...

saboh12617 · Answer

Salut @Bayard, Ce soit être possible de l'ajuster. Peux-tu partager le fichier/le code correspondant s'il te plait ...

saboh12617 · Answer

Ok parfait ! Content que tu aies pu ajuster.

Oui pour traiter tous les cas de bords (première/dernière ligne/colonne) il faudrait complexifier un peu le code avec un Max/Min pour vérifier si on n'est pas déjà le + à droite ou à gauche. Quelque chose comme

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 As Long, posy As Long, 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

    ' decalage voulu inséré ici
    Dim decalageX As Long: decalageX = -1
    Dim decalageY As Long: decalageY = 2
    With WorksheetFunction
      posx = Cells(MSjour.Row, .Min(.Max(MSjour.Column + decalageX, 1), Columns.Count - 4)).Left + 2
      posy = Cells(.Min(.Max(MSjour.Row + decalageY, 1), Rows.Count - 10), MSjour.Column).Top + 2
    End With

     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 As Long, y As Long, 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

Mais bon c'est plus lourd comme code (j'ai aussi du transformer les variables de integer vers Long pour éviter les overflow). Par contre ça fonctionne de la cellule A1 à XFD1048576 sans problème.

saboh12617 · Answer

Top ! Bonne journée & au plaisir...