XL 2016 Format Date "##/##/####" dans TextBox

[Lorenzini]

Bonjour,
Est-il possible d'afficher un textbox avec les slash de séparation pour une date (sans devoir les taper) ?
L'utilisateur n'aurait qu'à rentrer le jour, p.ex. 12, puis, le curseur se déplacerait après le slash déjà présent.
Il rentrerait ensuite le mois, p.ex. 05...le curseur se déplacerait de nouveau après le second (et dernier) slash aussi présent... puis, il ne resterait plus qu'à rentrer l'année : p.ex. 2020... et au final, mon textbox afficherait : 12/05/2020
J'ai trouvé ces qq lignes de code sur le web et les ai (dans les limites de mes connaissances rudimentaires en VBA) "bidouillées" à mon goût.
Ce n'est pas mal, mais ce n'est pas encore ce que je recherche.
Le code en question ne permet la saisie que des chiffres (0 à 9) et affiche les "/" au fur et à mesure de la saisie.
Pouvez-vous me dire si afficher un textbox avec slashs comme expliqué ce-dessus est réalisable en VBA ?
Merci

'********************************************************************************************************************************
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If Len(TextBox1.Text) <> 10 Or Not IsDate(TextBox1.Text) Then
        MsgBox "Entrez la date avec le format 'jjmmaaaa' !"
            TextBox1.Text = ""
            TextBox1.SetFocus
            Exit Sub
    End If
End Sub
'*******************************************************************************************************************************
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 8 Then
        If Right(TextBox1, 1) = "/" Then TextBox1 = Mid(TextBox1, 1, Len(TextBox1) - 1)
        ElseIf KeyCode = 46 Then TextBox1 = ""
    End If
End Sub
'********************************************************************************************************************************
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode < 96 Or KeyCode > 105 Then
        If TextBox1 <> "" Then TextBox1 = Left(TextBox1, Len(TextBox1) - 1)
    End If
    Select Case Len(TextBox1.Text)
    Case 2: If Val(TextBox1.Value) > 31 Then TextBox1.Value = "": MsgBox "jour trop grand" Else TextBox1 = TextBox1 & "/"
    Case 5: If Mid(TextBox1, 4, 2) > 12 Then TextBox1.Value = Mid(TextBox1, 1, 3): MsgBox "mois trop grand" Else TextBox1 = TextBox1 & "/"
    Case 10: If Not IsDate(TextBox1) Then MsgBox "Tu veux une claque ou quoi ?" & vbCrLf & " Où t'as vu que ce jour existe dans le calendrier" & vbCrLf & " Allez recommence !!!": TextBox1 = ""
    Case 11: TextBox1 = Mid(TextBox1, 1, 10)
    End Select
End Sub
'********************************************************************************************************************************
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If InStr("0123456789", Chr(KeyAscii)) = 0 Then KeyAscii = 0
End Sub
'********************************************************************************************************************************

 

[patricktoulon]

nothing

 

[jmfmarques]

Quelqu'un pour me dire comment et pourquoi l'utilisateur peut ainsi en arriver à de telles étapes (entre autres) en cours de saisie :
00/0
11/01/0000
?
(ce que j'ai pu faire à plusieurs reprises )

 

[patricktoulon]

et ben tu fait le menage dans les bascules t'arrange un peu et voila

Option Explicit
Const separator As String = "/"
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    ControlValiddateFR TextBox1, KeyAscii
End Sub
'new version avec control sur reprise
Private Sub ControlValiddateFR(txtb, KeyAscii)    'uniquement FR
    Dim t$, pos&
    If Not Chr(KeyAscii) Like "*[0-9]*" Then KeyAscii = 0: Exit Sub
    With txtb
        t = .Value    'Mid(.Value, 1, .SelStart)
        If .SelStart + 1 < Len(t) Then Mid(t, .SelStart + 1, 1) = Chr(KeyAscii): pos = .SelStart + 1 Else t = t & Chr(KeyAscii):
        If Len(t) = 2 Or Len(t) = 5 Then t = t & separator
        If Len(t) >= 5 Then If Val(Mid(t, 4, 2)) > 12 Then t = Left(t, 3): Beep
        If Len(t) >= 6 Then If Not IsDate(Left(t, 6) & "2000") Then t = Left(t, 3): Beep
        If Len(t) >= 7 And Mid(t, 7, 1) < 1 Then t = Left(t, 6): Beep
        If Len(t) = 10 And Not IsDate(t) Then t = Left(t, 6): Beep
        If Len(t) > 1 Then If Val(t) > 31 Or Val(t) = 0 Then t = "": Beep
        .Value = Mid(t, 1, 10)
        If pos > 0 Then .SelStart = pos: If Mid(t, pos + 1, 1) = "/" Then .SelStart = pos + 1
    End With
    KeyAscii = 0
End Sub

y'a que toi pour essayer de taper le jour ou mois 00
allez essaie de taper tes zéro maintenant et même revenir avec des zero par millier
allez cours Forest
pour info ça ne m'est jamais arrivé de taper 2 zeros de suite dans une date même par erreur
merci quand même jacques j'avais jamais voulu le faire sans masques de saisie tu m'y force

 

[patricktoulon]

allez comme ca je fait plaisir a GALOUGALOU
un const pour l'année en plus permet de gérer les années 1000 ou 2000

Option Explicit
Const separator As String = "/"
Const Minyear As Long = 2 ' pour l'année et ne pas descendre en dessous de 2000 on met 2  ou  1 pour 1000

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    ControlValiddateFR TextBox1, KeyAscii
End Sub
'new version avec control sur reprise
Private Sub ControlValiddateFR(txtb, KeyAscii)    'uniquement FR
    Dim t$, pos&
    If Not Chr(KeyAscii) Like "*[0-9]*" Then KeyAscii = 0: Exit Sub
    With txtb
        t = .Value
        If .SelStart + 1 < Len(t) Then Mid(t, .SelStart + 1, 1) = Chr(KeyAscii): pos = .SelStart + 1 Else t = t & Chr(KeyAscii):
        If Len(t) = 2 Or Len(t) = 5 Then t = t & separator
        If Len(t) >= 5 Then If Val(Mid(t, 4, 2)) > 12 Then t = Left(t, 3): Beep
        If Len(t) >= 6 Then If Not IsDate(Left(t, 6) & "2000") Then t = Left(t, 3): Beep
        If Len(t) >= 7 And Mid(t, 7, 1) < Minyear Then t = Left(t, 6): Beep
        If Len(t) = 10 And Not IsDate(t) Then t = Left(t, 6): Beep
        If Len(t) > 1 Then If Val(t) > 31 Or Val(t) = 0 Then t = "": Beep
        .Value = Mid(t, 1, 10)
        If pos > 0 Then .SelStart = pos: If Mid(t, pos + 1, 1) = "/" Then .SelStart = pos + 1
    End With
    KeyAscii = 0
End Sub

 

[jmfmarques]

Tu voudras bien m'excuser, Patrick, mais tu voudras également bien comprendre qu'un outil est destiné à un utilisateur et que je le teste donc en tant que tel (et en aucune manière autrement)
Je n'ai par ailleurs surtout pas l'intention de passer mon temps à repérer tous les manquements (il y en a d'autres) ni de recenser tous les cas où une erreur que l'utilisateur aurait corrigée très facilement (en ne modifiant qu'un chiffre) sans cet outil le conduit (quel progrès !) à reprendre beaucoup de choses s'il veut s'en sortir, dès lors que l'outil semble décider à la place de l'utilisateur ce qu'il devrait changer
Relis ce que j'ai déjà dit plus haut à propos de "convivialités" qui finissaient par devenir de temps à autre des gênes.
Voilà tout, Patrick (mais il me semble bien te l'avoir déjà dit un jour. Et que je n'étais pas le seul à la faire, non ?)

 

[patricktoulon]

oui tu l'a dit je m'en rappelle très bien quand aux autres se sont des moutons de Panurge qui t'on suivi (pense en ce que tu veux) mais je suis pas d'accord avec ton raisonnement et je le serais jamais
et tu viens encore de m'en donner la raison en trouvant les failles
si tu a trouvé une faille c'est que ça t'est possible de taper une erreur ça a donc son utilité quoi que tu en dise

 

[Docmarti]

...
Lorsque j'ouvre un formulaire, j'ai un textbox.
J'aimerais qu'en fait, il m'affiche uniquement les "/" ; il se présenterait donc comme ceci : " / / ".
Pour qu'ensuite, dès que l'on rentre dans le textbox, on tape 2 chiffres (le jour) et hop, le curseur "saute" le premier slash déjà présent...ensuite, on tape les 2 chiffres suivants pour le mois et rehop, le curseur saute le slash déjà présent lui aussi, pour enfin taper l'année.
Je ne sais pas si j'ai été assez clair, mais c'est l'idée...

Bonjour Lorenzini, le forum.
Voici un petit programme VBA qui fait seulement cela. Il est base sur un principe tres simple, soit demarrer avec ce texte __/__/____ dans le Textbox et remplacer l'un apres l'autre dans le Textbox les 8 caracteres _ (caractere de soulignement).

 

[patricktoulon]

bonsoir Docmarti
essaie celui la

Collection textbox formatés(patricktoulon)Un DateBox avec masque de saisie

Bonjour a tous je vous propose ma fonction qui transforme un TextBox en Date Box pour les 3 formats principaux il vous est impossible de taper une date erronée la gestion d'erreur re sélectionne le segment de la chaîne tapée qui est une...

www.excel-downloads.com

 

[patricktoulon]

tiens Docmarti
tu veux le masque de saisie sans control date version ultra simplifié

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    controlkeydown TextBox1, KeyCode
End Sub

Sub controlkeydown(txtb, KeyCode)
    Dim mask$, x&, xp&, s&, plus&
    mask = "__/__/____"
    With txtb
        t = .Value
        s = IIf(.SelLength > 0, .SelLength, 1): x = .SelStart
        plus = IIf(KeyCode < 96, 32, -48)
        Select Case KeyCode

        Case 96 To 105
            'If Mid(t, 1, x) Like "*_*" Then x = InStr(1, t, "_") - 1: .SelStart = x' facultatif
            If x = 10 Then KeyCode = 0: Exit Sub
            x = x + IIf(x = 2 Or x = 5, 1, 0): Mid(t, x + 1, 1) = Chr(KeyCode + plus): x = x + 1:

        Case 8: If x > 0 Then Mid(t, x, 1) = Mid(mask, x, 1): x = x - 1: x = IIf(x = 6 Or x = 3, x - 1, x)

        Case 46:
            t = IIf(s = 10, mask, t): xp = IIf(x = 0, 1, x + 1)
            Mid(t, xp, s + 1) = Mid(mask, xp, s + 1)

        Case Else: KeyCode = 0
        End Select
        .Value = t: .SelStart = x
    End With
    KeyCode = 0
End Sub

 

[fanch55]

Salut Patrick,
J'ai testé le Datebox de ta collection,
pour quelqu'un qui tape exactement ce qui est attendu, il doit être efficace.
Après maintes batailles entre les chiffres qui s'effacent, les bons comme les mauvais,les retours en arrières intempestifs et le curseur qui se place à des positions non stratégiques, je suis arrivé à ce résultat final :

Il est vrai qu'il met en surbrillance ce qui est incorrect et a tendance à supprimer parfois plus que celui-ci, mais il laisse passer sur l'exit ou le lostfocus .
Sur trois textbox, j'ai une "vraie" date qui est passée sauf que 2019 n'est pas bissextile ...

S'il faut taper un 02 pour qu'il comprenne 2 en tant que jour( 02/...) ,
ou même en tant que mois ( 02/02/.. = 2/2/.. ) je ne vois pas l'utilité d'une textbox par rapport à une cellule qui elle est capable de traduire et de compléter par l'année ( quoique, Excel à tendance à une traduction saxonne ==> 4/2 donne 2 avril 2020 ).
Il faudrait laisser la latitude à l'opérateur de saisir le slash ....

 

[patricktoulon]

bonsoir fanch55
je ne sais ce que tu a essayé mais c'est pas mon date box 29/02/2019 et tout bonnement impossible
à taper
d'autant plus qu'il ne fonctionne pas sur oleobject(sur feuille) donc soit tu l'a modifié soit c'est pas mon code

il strictement conçu pour textboxs on userform alors ta capture sur feuille me laisse perplexe

pour le reste oui seul l’événement exit peut t'avertir vba ne devine pas tes intentions
si tu reprends une partie et que tu va pas jusqu'au bout ça vba peut pas anticiper

donc effectivement le exit ou lostfocus rentre en jeu
ça c'est a l'utilisateur de faire le test date de la chaîne complète au moment qui lui est nécessaire

ce module a été testé pendant des semaines tordus dans tout les sens et personne n'a réussi a le déjouer et encore moins taper un 29/02 année non bissextile surtout que c'est le test1 jusqu’à 9 caractères

je suppose que vous préféreriez le comportement de la version 2014 UNIQUEMENT FR
qui elle fonctionne comme avec 3 textboxs distincts segments par segments
celle ci non seulement elle met en évidence l'erreur mais elle la remplace par les caractères du masque

Option Explicit
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
control_saisieX TextBox1, KeyCode
End Sub

Sub control_saisieX(txt As Object, KeyCode)
    Dim Pos&, T$, X&, XL&, J&, M&, A&, MasK$, ldate As Date
    MasK = "__/__/____":
    With txt
        If .Value = "" Then .Value = MasK
        T = .Value: If T = MasK Then .SelStart = 0
        X = .SelStart: XL = .SelLength
        Select Case KeyCode
        Case 96 To 105
            Select Case X
            Case 0 To 1, 3 To 4, 6 To 9
                XL = IIf(XL = 0, 1, XL): Mid$(T, X + 1, XL) = Chr(KeyCode - 48) & Mid$(MasK, X + 2, XL): .Value = T: KeyCode = 0: Pos = InStrRev(Mid$(T, 1, X + 1), "/")
            Case Else: KeyCode = 0
            End Select
            '_______________________________________________________________________________________
            'controle de la validité de la date
            J = Val(Mid$(T, 1, 2)): M = Val(Mid$(T, 4, 2)): A = IIf(Mid$(T, 7, 4) Like "*_*", 2000, Val(Mid$(T, 7, 4)))   'récuperation du jour  mois année en fonction de l'etat de la saisie
            J = IIf(J = 0, 1, J): M = IIf(M = 0, 1, M): ldate = DateSerial(A, M, J)   'date théorique ou reele dynamique
            If Day(ldate) <> J Or Month(ldate) <> M Or Year(ldate) <> A Or Val(Mid$(T, 1, 1)) > 3 Or Val(Mid$(T, 4, 1)) > 1 Or Mid(T, 4, 2) = "00" Or Mid(T, 1, 2) = "00" Or A = 0 Then  'Condition d 'erreur globale
                XL = IIf(Pos = 6, 4, 2): Mid$(T, Pos + 1, XL) = "____": .Value = T: .SelStart = Pos: .SelLength = XL: Beep: .BackColor = &HAAB4FF    'annulation et repositionnement
            Else
                If Mid$(T, X + 2, 1) = "/" Then .SelStart = X + 2 Else .SelStart = X + 1: .BackColor = vbWhite    'passe a la suite si ok
            End If

        Case 8: KeyCode = 0: X = InStrRev(T, "/", IIf(X = 1, 2, X - 1)): XL = IIf(X = 6, 4, 2): Mid$(T, X + 1, XL) = "____": .Value = T: .SelStart = X: .SelLength = XL
            .BackColor = vbWhite

            'Case 9 'voir case 39(touche fleche droite)

        Case 13: If InStr(txt.Value, "_") Then KeyCode = 0    'empeche la sortie par la touche enter si pas fini

        Case 37: KeyCode = 0: X = InStrRev(T, "/", IIf(X = 1, 2, X - 1)): XL = IIf(X = 6, 4, 2): .SelStart = IIf(T = MasK, 0, X): .SelLength = IIf(T = MasK, 0, XL)
       
        Case 39, 9: Pos = X + InStr(1, Mid$(T, X + 1), "/"): Pos = IIf(Pos = X, 0, Pos): XL = IIf(Pos = 6, 4, 2): .SelStart = IIf(T = MasK, 0, Pos): .SelLength = IIf(T = MasK, 0, XL): KeyCode = 0

        Case 46: XL = IIf(XL = 0, 1, XL): KeyCode = 0: Mid$(T, X + 1, XL) = Mid$(MasK, X + 1, XL): .Value = T: .SelStart = IIf(T = MasK, 0, X)

        Case Else: KeyCode = 0
        End Select
    End With
End Sub

amuse toi bien

 

[Usine à gaz]

Tu dors pas toi

 

[patricktoulon]

re
Bonjour Lionel
ben si je viens de me réveiller

 

[jmfmarques]

ce module a été testé pendant des semaines tordus dans tout les sens et personne n'a réussi a le déjouer et encore moins taper un 29/02 année non bissextile surtout que c'est le test1 jusqu’à 9 caractères

Cà, c'est bien vrai, Patrick. ça l'est même au point qu'aucune date (valide ou non) ne pourrait être saisie sur certaines machines ***** , dès lors que tu utilises le keycode comme tu le fais.
Je n'avais jusqu'à présent même pas essayé ce code, car je savais bien ce qui allait se produire sur l'une de mes machines ***** .
Je viens quand même de le faire (par pur acquis de conscience) --->> confirmation de l'impossibilité absolue de saisir le moindre chiffre.
Je ne voudrais pas t'empêcher de dormir, mais voilà voilà ...

EDIT : ***** --->> DELL Ultrabook Latitude E7450 (pas de pavé numérique) sous Windows 10

 

[patricktoulon]

re
bonjour jmfmarques
oui je sais ça sur dvp tu trouvera une version qui englobe les 2 pavés numériques avec keycode
je l'ai pas remis c'est vrai
donc voila action réaction

comme il semblerait que certains préfère le part off mask plutôt que la mise en évidence par le sellength
voila la version 2014 remastérisée et condensé

'****************************************
'textbox date controlée version FR
'patricktoulon
'version 12/06/2014
'mise a jour
'date 11/05/2020
' condensation du code
'basé sur le mid(texte,1,5)+année permutée ce qui permet de faire moins de tests
'remise en place du pavé numerique haut du clavier
'******************************************
Option Explicit

Const MasK As String = "__/__/____"
Const separateur = "/"

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    control_saisieX TextBox1, KeyCode
End Sub

Sub control_saisieX(txt As Object, KeyCode)
     Dim Pos&, T$, X&, XL&, xp&, an
    With txt
        If .Value = "" Then .Value = MasK
        T = .Value: .SelStart = IIf(T = MasK, 0, .SelStart): X = .SelStart: XL = .SelLength
If KeyCode <= 57 Then KeyCode = KeyCode + 48
        Select Case KeyCode
        Case 96 To 105    'pavé numerique
            Select Case X
            Case 0 To 1, 3 To 4, 6 To 9    'en fonction du selstart
                XL = IIf(XL = 0, 1, XL)
                Mid$(T, X + 1, XL) = Chr(KeyCode - 48) & Mid$(MasK, X + 2, XL): X = X + 1    'placement du caractere

                'controle date condensé
                If Val(T) > 31 Then Mid$(T, 1, 2) = Mid$(MasK, 1, 2): X = 0: Beep 'max 31 pour jour
                If Val(Mid(T, 4, 2)) > 12 Then Mid$(T, 4, 2) = Mid$(MasK, 4, 2): X = 3: Beep ' max 12 pour le mois
                If X > 5 Then xp = 7 Else If X < 4 Then xp = 1 Else xp = 4 'calcul position pour replace by mask
                If IsNumeric(Mid(T, 7, 4)) And X > 5 Then an = Mid(T, 7, 4): XL = 5 Else an = "2000": XL = 2 'année permuté
                If IsDate(Mid(T, 1, 5)) Then
                    If Not IsDate(Mid(T, 1, 5) & separateur & an) Then Mid(T, xp, XL) = Mid(MasK, xp, XL): Beep: X = InStr(1, T, "_") - 1
                End If

                .Value = T: .SelStart = IIf(Mid(MasK, X + 1, 1) = separateur, X + 1, X)    'mise a jour textbox et positionement final

            Case Else: .SelStart = X + 1: KeyCode = 0
            End Select

        Case 8: If X > 0 Then Mid(T, X, 1) = Mid(MasK, X, 1): .Value = T: .SelStart = X - 1   'touche "back"
            If Mid(T, X - 1, 1) = separateur Then X = X - 1: .SelStart = X - 1
        Case 46: Mid(T, X + 1, XL) = Mid(MasK, X + 1, XL): .Value = T: .SelStart = X    'touche "suppr"
        Case Else: KeyCode = 0    'aucune autre touche autorisée
        End Select
    End With
    KeyCode = 0:
End Sub

y va être content le jacques avec son dell