XL 2019 Saisir automatiquement des dates au moyen d'un calendrier

[Magic_Doctor]

Bonsoir,

Ma fille en avait besoin pour son travail : dans une colonne de cellules qui ne reçoivent que des dates, quand on clique sur l'une de ces cellules, faire apparaître un petit calendrier à partir duquel on choisirait une date qui s'inscrirait dans la cellule.
J'ai cherché un peu partout, mais rien qui correspondait à ce que je voulais exactement. Je décide de résoudre le problème avec l'humanoïde. En moins de 2 minutes il me le résout sommairement, puis des heures d'échanges et d'essais pour peaufiner cette histoire et que surtout ça ne plante pas.
Résultat : bluffant.
Mais, je dois reconnaître, histoire complexe dont plusieurs procédures me dépassent. Ce n'est pas grave, l'essentiel, c'est que ça marche.
Je partage, et si quelqu'un peut trouver plus simple pour au moins le même résultat, je suis preneur.

¡FELIZ AÑO NUEVO A TODOS!

 

[patricktoulon]

Bonjour à tous
@Rheeem
et voici la version 3.3 ou l'on peut mettre un peu de couleur en mode édition dans le VBE

 

[Rheeem]

Bonsoir,

L'idée est bonne comme pas mal d'autres personnalisation qui sont envisageables concernant la validité des dates la possibilité de changer l'année / le mois pour restreindra la sélection , à mon avis c'est un mouvais choix que le jeu de couleur par défaut soit basé sur le gris , personne n'aime donner à son calendrier le look d'un vieux os.

 

[patricktoulon]

Bonjour @Rheeem
Change le avec les bouton dans le vbe

Pour afficher ce contenu, nous aurons besoin de votre consentement pour définir des cookies tiers.
Pour plus d'informations, consultez notre page sur les cookies.

Accepter les cookies de tiers

 

[Rheeem]

Bonsoir,

Cette version c'est mieux on laisse le style du système par défaut car il y aura peu qui vont changer cette configuration, j'ai un autre remarque dans cette version et la précédente tu as ré-introduits un bug qui concerne la position du dialogue au lancement actuellement StartUpPosition force la position au center de l'écran et ne tient pas compte de la position indiquée dans Initialize et cela crée un effet visuel désagréable le dialogue s'affiche pour un laps de temps au centre de l'écran avant de prendre sa position.
Au début de Initialize ajouter :
StartUpPosition = 0
et à la fin de Activate remets ces lignes :

  If Left = 0 Then
     Move (Application.Width - Width) / 2, (Application.Height - Height) / 2
  End If

 

[patricktoulon]

bonjour @rheem
le mode center est necessaire pour les appels sans appelant
je pourrais eventuellement faire un switch dans le callback datevaluex

c'est quand même etonnant je n'ai pas cet effet chez moi le calendar apparait directement a l'endroit demandé

 

[patricktoulon]

voila la fonction avec le switch pour le startupposition

'callback pour la classe calendrier
Public Function DateValueX(Optional obj As Object = Nothing, Optional langue As Long = -1)
    Dim forme
    With Calendrier
       If obj Is Nothing Then
       .StartUpPosition = 1
       Else
      .StartUpPosition = 0
      End If
       .DateSepar = Switch(langue = 0, "/", langue = 2, "-", langue = 1, "/", langue = -1 Or langue > 2, Application.International(xlDateSeparator))
        .DateOrder = Switch(langue > -1, langue, langue = -1 Or langue > 2, Application.International(xlDateOrder))
        If Not obj Is Nothing Then
            Set .obj = obj
            Select Case TypeName(obj)
                Case "Range"
                    If IsDate(obj.Value) Then .dat = CDate(obj.Value) Else dat = Date
                    oldate = obj.Value
                Case "TextBox"
                    If IsDate(obj.Text) Then .dat = CDate(obj.Text) Else dat = Date
                    oldate = obj.Text
                Case "Label", "CommandButton"
                    If IsDate(obj.Caption) Then .dat = CDate(obj.Caption) Else dat = Date
                    oldate = obj.Caption
                Case "Shape", "DrawingObject"
                    If IsDate(ActiveSheet.DrawingObjects(obj.Name).Text) Then .dat = CDate(ActiveSheet.DrawingObjects(obj.Name).Text) Else dat = Date
                    oldate = ActiveSheet.DrawingObjects(obj.Name).Text
                Case Else: dat = Date 'au cas ou l'appelant n'est pas identifié
            End Select
        Else
            dat = Date
        End If
        
        If obj Is Nothing Then Me.StartUpPosition = 1
        Show
        Select Case .DateOrder
            Case 0, 2: forme = "yyyy" & .DateSepar & "mm" & .DateSepar & "dd"
            Case 1: forme = "DD" & .DateSepar & "mm" & .DateSepar & "yyyy"
        End Select
        If .Tag <> "no" Then
            Select Case TypeName(obj)
                Case "Range"
                    DateValueX = dat
                    If langue > -1 Then obj.NumberFormat = forme
                Case "TextBox", "Label", "CommandButton", "Shape"
                    DateValueX = Format(dat, forme)
                Case Else: DateValueX = dat
            End Select
        Else
            DateValueX = oldate 'si on ferme par la croix on remet ce qu'il y avait
        End If
        Unload Calendrier
    End With
End Function

si tu a toujours cet effet de deplacement du centre vers sa position demandé on placera le userform avant affichage

 

[patricktoulon]

re : @Rheeem
voila maintenant le left et top du calendrier son decidés avant affichage
si appelant startupposition=0 et placement ,sinon 1
et les fonctions de position sont solicitées dans le callback datevaluex(avant affichage)