Faciliter la saisie d'une date

Vous ne lâchez rien Steelson !

Bravo à vous !

@ bientôt

LouReeD

Et en plus je transgresse mes interdits (cellules fusionnées contenant des données)

Vous avez le bon avatar alors :" bon sang, qu'est ce que je suis en train de faire ?"

@ bientôt

LouReeD

bonjour et merci encore pour votre implication, j ai récupéré les codes et je tacherai de voir si je peux l adapter sur mon projet, je vous tiendrais informé des avancées en attendant encore merci

bonjour Steelson, donc ça y est j' ai pu mettre en place le code que vous avez modifié, cela fonctionne plutôt bien le seul bémol c est que dés que je clique sur une cellule concernée cela met un peu de temps pour afficher le calendrier, je pense que c est du fait que j ai pas mal de macros en place, mais sinon plutôt cool et je fait avec, en tout cas je tenait a remercier pour avoir pris le temps de modifier le code

@bientôt

Merci pour ce retour

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
Rechercher des sujets similaires à "faciliter saisie date"